Commit 00b529b7 authored by Alp Mestanogullari's avatar Alp Mestanogullari

improve performance

parent 67a730e4
...@@ -16,8 +16,6 @@ import Prelude (String) ...@@ -16,8 +16,6 @@ import Prelude (String)
import Protolude import Protolude
import qualified Data.IntMap as Dict import qualified Data.IntMap as Dict
import qualified Data.List as List import qualified Data.List as List
import qualified Eigen.Matrix as Matrix
import qualified Eigen.SparseMatrix as SMatrix
import qualified Prelude as Prelude import qualified Prelude as Prelude
import qualified Data.Graph.Inductive.PatriciaTree as DGIP import qualified Data.Graph.Inductive.PatriciaTree as DGIP
...@@ -31,9 +29,11 @@ setupEnv _ = getUnlabGraph Random ...@@ -31,9 +29,11 @@ setupEnv _ = getUnlabGraph Random
main :: IO () main :: IO ()
main = do main = do
fp <- getArgs fp <- getArgs
setupEnv fp >>= \(_, ~g) ->
withArgs [] $ evaluate $ withG g (clusteringOptim 3 Conf)
defaultMain return ()
[ env (snd <$> setupEnv fp) $ \ ~g -> -- withArgs [] $
bench "bench" (nf (\ x -> withG x (parts . clusteringOptim 3 Conf)) g) -- defaultMain
] -- [ env (snd <$> setupEnv fp) $ \ ~g ->
-- bench "bench" (nf (\ x -> withG x (parts . clusteringOptim 3 Conf)) g)
-- ]
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0. -- This file has been generated from package.yaml by hpack version 0.34.4.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
...@@ -9,8 +9,8 @@ cabal-version: 1.12 ...@@ -9,8 +9,8 @@ cabal-version: 1.12
name: gargantext-graph name: gargantext-graph
version: 0.1.0.0 version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/gargantext-graph#readme> description: Please see the README on GitHub at <https://github.com/githubuser/gargantext-graph#readme>
homepage: https://github.com/https://gitlab.iscpif.fr/gargantext/gargantext-graph#readme homepage: https://github.com/gargantext/gargantext-graph#readme
bug-reports: https://github.com/https://gitlab.iscpif.fr/gargantext/gargantext-graph/issues bug-reports: https://github.com/gargantext/gargantext-graph/issues
author: Alexandre Delanoë author: Alexandre Delanoë
maintainer: alexandre+dev@delanoe.org maintainer: alexandre+dev@delanoe.org
copyright: 2021 CNRS / Alexandre Delanoë copyright: 2021 CNRS / Alexandre Delanoë
...@@ -23,12 +23,12 @@ extra-source-files: ...@@ -23,12 +23,12 @@ extra-source-files:
source-repository head source-repository head
type: git type: git
location: https://github.com/https://gitlab.iscpif.fr/gargantext/gargantext-graph location: https://github.com/gargantext/gargantext-graph
library library
exposed-modules: exposed-modules:
Data.Array.Accelerate.Utils Data.Array.Accelerate.Utils
Data.Eigen.Coeff -- Data.Eigen.Coeff
Graph.BAC.Clustering Graph.BAC.Clustering
Graph.BAC.Proxemy Graph.BAC.Proxemy
Graph.BAC.ProxemyOptim Graph.BAC.ProxemyOptim
...@@ -45,7 +45,10 @@ library ...@@ -45,7 +45,10 @@ library
Paths_gargantext_graph Paths_gargantext_graph
hs-source-dirs: hs-source-dirs:
src src
default-extensions: DataKinds FlexibleInstances OverloadedStrings default-extensions:
DataKinds
FlexibleInstances
OverloadedStrings
build-depends: build-depends:
accelerate accelerate
, accelerate-arithmetic , accelerate-arithmetic
...@@ -55,14 +58,16 @@ library ...@@ -55,14 +58,16 @@ library
, cassava , cassava
, cereal , cereal
, containers , containers
, eigen -- , eigen
, fgl , fgl
, haskell-igraph >=0.6.0 , haskell-igraph >=0.6.0
, hmatrix
, lens , lens
, pretty-simple , pretty-simple
, protolude , protolude
, reflection , reflection
, singletons , singletons == 2.7
, sparse-linear
, string-conversions , string-conversions
, text , text
, vector , vector
...@@ -86,7 +91,7 @@ executable gargantext-graph-exe ...@@ -86,7 +91,7 @@ executable gargantext-graph-exe
, cereal , cereal
, containers , containers
, criterion , criterion
, eigen -- , eigen
, fgl , fgl
, gargantext-graph , gargantext-graph
, haskell-igraph >=0.6.0 , haskell-igraph >=0.6.0
...@@ -107,7 +112,10 @@ test-suite gargantext-graph-test ...@@ -107,7 +112,10 @@ test-suite gargantext-graph-test
Paths_gargantext_graph Paths_gargantext_graph
hs-source-dirs: hs-source-dirs:
test test
default-extensions: DataKinds FlexibleInstances OverloadedStrings default-extensions:
DataKinds
FlexibleInstances
OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
QuickCheck QuickCheck
...@@ -119,7 +127,7 @@ test-suite gargantext-graph-test ...@@ -119,7 +127,7 @@ test-suite gargantext-graph-test
, cassava , cassava
, cereal , cereal
, containers , containers
, eigen -- , eigen
, fgl , fgl
, gargantext-graph , gargantext-graph
, haskell-igraph >=0.6.0 , haskell-igraph >=0.6.0
......
name: gargantext-graph name: gargantext-graph
version: 0.1.0.0 version: 0.1.0.0
github: "https://gitlab.iscpif.fr/gargantext/gargantext-graph" github: gargantext/gargantext-graph
license: AGPL license: AGPL
author: "Alexandre Delanoë" author: "Alexandre Delanoë"
maintainer: "alexandre+dev@delanoe.org" maintainer: "alexandre+dev@delanoe.org"
......
{-# LANGUAGE BangPatterns #-}
{-| Module : Gargantext.Core.Viz.Graph.ProxemyOptim {-| Module : Gargantext.Core.Viz.Graph.ProxemyOptim
Description : Proxemy Description : Proxemy
Copyright : (c) CNRS, 2017-Present Copyright : (c) CNRS, 2017-Present
...@@ -30,35 +31,33 @@ Gaume. ...@@ -30,35 +31,33 @@ Gaume.
, MultiParamTypeClasses , MultiParamTypeClasses
#-} #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Graph.BAC.ProxemyOptim module Graph.BAC.ProxemyOptim
where where
--import Debug.SimpleReflect
import Data.Eigen.Coeff (coeffSM, coeffDM)
import Data.IntMap (IntMap) import Data.IntMap (IntMap)
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Data.Proxy (Proxy(Proxy)) import Data.Proxy (Proxy(Proxy))
import Data.Reflection import Data.Reflection
import Eigen.Internal (CTriplet(..), Elem(..), toC, fromC, C(..), natToInt, Row(..), Col(..))
import Eigen.Matrix (sum)
import Eigen.SparseMatrix (SparseMatrix, SparseMatrixXd, (!), toMatrix)
import GHC.TypeLits (KnownNat, Nat, SomeNat(SomeNat), type(+), natVal, sameNat, someNatVal) import GHC.TypeLits (KnownNat, Nat, SomeNat(SomeNat), type(+), natVal, sameNat, someNatVal)
import Graph.FGL import Graph.FGL
import Graph.Types import Graph.Types
import Prelude (String, readLn) import Prelude (String, readLn, error)
import Protolude hiding (sum, natVal) import Protolude hiding (sum, natVal, trace)
import qualified Eigen.Matrix as DenseMatrix
import qualified Data.Graph.Inductive as DGI import qualified Data.Graph.Inductive as DGI
import qualified Data.Graph.Inductive.PatriciaTree as DGIP import qualified Data.Graph.Inductive.PatriciaTree as DGIP
import qualified Data.List as List import qualified Data.List as List
import qualified Data.IntMap as Dict import qualified Data.IntMap as Dict
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
import qualified Eigen.Matrix as DMatrix
import qualified Eigen.SparseMatrix as SMatrix
import qualified Prelude as Prelude import qualified Prelude as Prelude
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Matrix.Sparse.Static as SMatrix
import qualified Data.Vector.Sparse.Static as SV
import qualified Numeric.LinearAlgebra.Static as DMatrix
import Debug.Trace
import qualified Data.Vector.Unboxed as UV
---------------------------------------------------------------- ----------------------------------------------------------------
...@@ -68,23 +67,25 @@ clusteringOptim :: forall n a b. (KnownNat n, Show a, Show b) ...@@ -68,23 +67,25 @@ clusteringOptim :: forall n a b. (KnownNat n, Show a, Show b)
-> Similarity -> Similarity
-> FiniteGraph n a b -> FiniteGraph n a b
-> Clustering Node -> Clustering Node
clusteringOptim l s fg@(FiniteGraph g) = -- traceShow ("mc", mc) $ clusteringOptim l s fg@(FiniteGraph g) = trace "clusteringOptim" $ -- traceShow ("mc", mc) $
make_clust_part sorted_edges matq make_clust_part sorted_edges matq
where where
adj = adjacent fg False adj = trace "adjacent False" $ adjacent fg False
tra = transition adj tra = trace "tra" $ transition adj
adj' = adjacent fg True adj' = trace "adjacent True" $ adjacent fg True
tra' = transition adj' tra' = trace "tra'" $ transition adj'
sorted_edges = sort_edges (natToInt @n) sorted_edges = adj `seq` tra `seq` adj' `seq` tra' `seq`
$ edges_confluence l adj' tra' (trace "sorted_edges"
$ sort_edges (natToInt @n)
$ edges_confluence l adj' tra')
mc = matconf False adj (proxemie l tra) mc = matconf False adj (proxemie l tra)
md = matmod fg md = matmod fg
matq = case s of matq = case s of
Conf -> SimConf mc -- $ matconf False adj (proxemie l tra) Conf -> SimConf mc -- $ matconf False adj (proxemie l tra)
Mod -> SimMod md -- $ matmod fg Mod -> SimMod md -- $ matmod fg
-- | Where main Types are defined as -- | Where main Types are defined as
data Similarity = Conf | Mod data Similarity = Conf | Mod
...@@ -114,8 +115,8 @@ type NeighborsFilter a b = DGI.Gr a b -> Node -> [Node] ...@@ -114,8 +115,8 @@ type NeighborsFilter a b = DGI.Gr a b -> Node -> [Node]
type RmEdge = Bool type RmEdge = Bool
--------------------------------------------------------------- ---------------------------------------------------------------
-- Data Structure -- Data Structure
type VectorS n = SparseMatrix 1 n Double type VectorS n = SMatrix.Matrix 1 n Double
type VectorD n = DenseMatrix.Matrix 1 n Double type VectorD n = DMatrix.L 1 n
type AdjacencyMatrix n = MatrixS n type AdjacencyMatrix n = MatrixS n
type TransitionMatrix n = MatrixS n type TransitionMatrix n = MatrixS n
...@@ -133,26 +134,24 @@ adjacent :: KnownNat n ...@@ -133,26 +134,24 @@ adjacent :: KnownNat n
=> FiniteGraph n a b => FiniteGraph n a b
-> IsReflexive -> IsReflexive
-> AdjacencyMatrix n -> AdjacencyMatrix n
adjacent (FiniteGraph g) isReflexive = adjacent (FiniteGraph g) isReflexive = trace "adjacent"
SMatrix.fromVector $ VS.fromList $ triplets <> diag SMatrix.fromList $ triplets <> diag
where where
triplets = [ CTriplet (toC i) (toC j) 1.0 triplets = [ (i, j, 1.0)
| i <- nodes g | i <- nodes g
, j <- neighbors g i , j <- neighbors g i
, i /= j , i /= j
] ]
diag = case isReflexive of diag = case isReflexive of
True -> [ CTriplet (toC n) (toC n) 1.0 True -> [ (n, n, 1.0) | n <- nodes g ]
| n <- nodes g
]
False -> [] False -> []
transition :: KnownNat n transition :: (HasCallStack, KnownNat n)
=> AdjacencyMatrix n => AdjacencyMatrix n
-> TransitionMatrix n -> TransitionMatrix n
transition m = SMatrix.imap (\i j v -> v * (VS.!) s i) m transition m = trace "transition" $ SMatrix.imap (\i j v -> v * (SV.!) s i) m
where where
s = sumWith Colonne (\s -> 1 / s) m s = sumWith Colonne (\s -> 1 / s) m
...@@ -161,10 +160,28 @@ proxemie :: KnownNat n ...@@ -161,10 +160,28 @@ proxemie :: KnownNat n
=> Length => Length
-> TransitionMatrix n -> TransitionMatrix n
-> ProxemyMatrix n -> ProxemyMatrix n
proxemie l tm = case l <= 1 of proxemie l tm = trace ("proxemie (l = " ++ show l ++ ")") $ case l <= 1 of
True -> toMatrix tm True -> SMatrix.densify tm
False -> toMatrix $ foldl' (\m' _-> SMatrix.mul m' tm) tm [2 .. (l :: Int)] False -> matInfo "proxemie tm" tm $
case matPow tm (l-1) of
tm' -> matInfo "proxemie tm'" tm' $ SMatrix.densify tm'
-- https://en.wikipedia.org/wiki/Exponentiation_by_squaring
matPow :: MatrixS n -> Int -> MatrixS n
matPow mat n
| n <= 0 = error "matPow: positive exponent expected"
| otherwise = f mat n
where
f a i
| even i = f (a `mul` a) (i `quot` 2)
| i == 1 = a
| otherwise = g (a `mul` a) (i `quot` 2) a
g a i b
| even i = g (a `mul` a) (i `quot` 2) b
| i == 1 = a `mul` b
| otherwise = g (a `mul` a) (i `quot` 2) (a `mul` b)
mul = SMatrix.mul
--------------------------------------------------------------- ---------------------------------------------------------------
matconf :: forall n. KnownNat n matconf :: forall n. KnownNat n
...@@ -172,34 +189,35 @@ matconf :: forall n. KnownNat n ...@@ -172,34 +189,35 @@ matconf :: forall n. KnownNat n
-> AdjacencyMatrix n -> AdjacencyMatrix n
-> ProxemyMatrix n -> ProxemyMatrix n
-> ConfluenceMatrix n -> ConfluenceMatrix n
matconf False a p = symmetry confmat matconf False a p = seq confmat $ trace "matconf" $ symmetry confmat
where where
-- vcount = natToInt @n -- vcount = natToInt @n
degs = sumWith Colonne identity a degs = DMatrix.extract $ SV.toDense (sumWith Colonne identity a)
sumdeg = VS.sum degs sumdeg = VS.sum degs
confmat = DMatrix.imap (\ x y v -> tp = DMatrix.tr p
if x < y confmat = seq tp . trace "confmat" $
then let DMatrix.imapL
prox_y_x_length = v (\(x, y) v ->
prox_y_x_infini = ((VS.!) degs x) / sumdeg if x < y
in then let prox_y_x_length = v
(prox_y_x_length - prox_y_x_infini) prox_y_x_infini = ((VS.!) degs x) / sumdeg
/ (prox_y_x_length + prox_y_x_infini) in
else 0 (prox_y_x_length - prox_y_x_infini)
) $ DMatrix.transpose p / (prox_y_x_length + prox_y_x_infini)
else 0
) tp
matconf True _a _p = panic "MatConf True: TODO but not needed for now" matconf True _a _p = panic "MatConf True: TODO but not needed for now"
matmod :: forall n a b. KnownNat n => FiniteGraph n a b -> ModularityMatrix n matmod :: forall n a b. KnownNat n => FiniteGraph n a b -> ModularityMatrix n
matmod fg = symmetry $ toMatrix modmat matmod fg = trace "matmod" $ symmetry $ SMatrix.densify modmat
where where
n' = natToInt @n n' = natToInt @n
a = adjacent fg False a = adjacent fg False
sumRows = sumWith Ligne identity a !sumRows = DMatrix.extract $ SV.toDense (sumWith Ligne identity a)
sumCols = sumWith Colonne identity a !sumCols = DMatrix.extract $ SV.toDense (sumWith Colonne identity a)
ecount = sum $ toMatrix a !ecount = SMatrix.sum a
modmat = SMatrix.imap (\x y v -> modmat = SMatrix.imap (\x y v ->
if x < y if x < y
then v - ((VS.!) sumRows x * (VS.!) sumCols y) / (2 * ecount) then v - ((VS.!) sumRows x * (VS.!) sumCols y) / (2 * ecount)
else 0 else 0
...@@ -209,36 +227,60 @@ matmod fg = symmetry $ toMatrix modmat ...@@ -209,36 +227,60 @@ matmod fg = symmetry $ toMatrix modmat
type UnsortedEdges = [(Node, Node, Double)] type UnsortedEdges = [(Node, Node, Double)]
type SortedEdges = [(Node, Node, Double)] type SortedEdges = [(Node, Node, Double)]
edges_confluence :: forall n a b matInfo
:: forall b (n :: Nat) (m :: Nat).
(KnownNat n, KnownNat m)
=> String
-> SMatrix.Matrix n m Double
-> b -> b
matInfo name mat = trace $
name ++ ": " ++ show nnz ++ "/" ++ show total ++
" (~" ++ pcstr ++ "%) nnz, " ++
szInfo ++
"\n\t= [ " ++ intercalate ", " snip ++ " , ... ]"
where total = n*m
nnz = SMatrix.nonZeros mat
pc = fromIntegral (100 * nnz) / fromIntegral total
pcstr = take 4 (show pc)
n = natToInt @n
m = natToInt @m
szInfo = show n ++ "x" ++ show m
snip = [ show (coeffSM 0 i mat) | i <- [1..10] ]
edges_confluence :: forall n
. KnownNat n . KnownNat n
=> Length => Length
-> AdjacencyMatrix n -> AdjacencyMatrix n
-> TransitionMatrix n -> TransitionMatrix n
-> UnsortedEdges -> UnsortedEdges
edges_confluence l am tm = -- traceShow ("degs", degs) $ edges_confluence l am tm = trace ("edges_confluence (dim = " ++ show vcount ++ ")") $ -- traceShow ("degs", degs) $
matInfo "am" am $ matInfo "tm" tm $
SMatrix.toList matconf' SMatrix.toList matconf'
where where
vcount = natToInt @n vcount = natToInt @n
degs = sumWith Colonne identity am degs = DMatrix.extract $ SV.toDense (sumWith Colonne identity am)
sumdeg = VS.sum degs !sumdeg = VS.sum degs
matconf' = SMatrix.imap !tmam = SMatrix.zipR 0 (,) am tm
(\x y _ -> matconf' = seq sumdeg $ trace "edges_confluence.matconf'" $ SMatrix.imap
(\x y _v ->
if x < y if x < y
then then
let let
deg_x = (VS.!) degs x - 1 !deg_x = (VS.!) degs x - 1
deg_y = (VS.!) degs y - 1 !deg_y = (VS.!) degs y - 1
tm' = SMatrix.imap (\i j v -> if (i == x && j == y) || ( i == y && j == x) !tm' = {- trace ("tm': " ++ show (x, y)) $ -} SMatrix.imap
then 0 (\i j (am_ij, tm_ij) ->
else if (i == x && j == y) || ( i == y && j == x)
if i == x && i /= y then 0
then (coeffSM i j am) / deg_x else
else if i == x && i /= y
if i == y && i /= x then am_ij / deg_x
then (coeffSM i j am) / deg_y else
else v if i == y && i /= x
) tm then am_ij / deg_y
else tm_ij
) tmam
v = fromList (Proxy @n) [(fromIntegral y,1)] v = fromList (Proxy @n) [(fromIntegral y,1)]
v' = doProx l v tm' v' = doProx l v tm'
...@@ -264,22 +306,18 @@ edges_confluence l am tm = -- traceShow ("degs", degs) $ ...@@ -264,22 +306,18 @@ edges_confluence l am tm = -- traceShow ("degs", degs) $
True -> panic "doProx" True -> panic "doProx"
False -> foldl' (\v'' _-> SMatrix.mul v'' tm'') v' [1 .. (l :: Int) ] False -> foldl' (\v'' _-> SMatrix.mul v'' tm'') v' [1 .. (l :: Int) ]
-- | TODO optimization
sort_edges :: Int sort_edges :: Int
-> UnsortedEdges -> UnsortedEdges
-> SortedEdges -> SortedEdges
sort_edges n = List.concat sort_edges n = trace "sort_edges"
. (map (List.sortOn (\(x,y,_) -> x * n + y))) . List.sortBy (\a b -> comparing third a b <> comparing xnpy a b)
. (List.groupBy (\x y -> third x == third y)) . List.filter (\(x,y,_) -> x < y)
. List.reverse
. (List.filter (\(x,y,_) -> x < y))
. (List.sortOn third)
where where
third third
:: forall a b c :: forall a b c
. (a,b,c) -> c . (a,b,c) -> c
third (_,_,c) = c third (_,_,c) = c
xnpy (x,y,_) = x*n+y
--------------------------------------------------------------- ---------------------------------------------------------------
...@@ -290,18 +328,18 @@ updateClustering c@(ClusteringIs parts idx currentScore _) f x y = ...@@ -290,18 +328,18 @@ updateClustering c@(ClusteringIs parts idx currentScore _) f x y =
let modX = fromMaybe 0 $ Dict.lookup x idx let modX = fromMaybe 0 $ Dict.lookup x idx
modY = fromMaybe 0 $ Dict.lookup y idx modY = fromMaybe 0 $ Dict.lookup y idx
in case x == y || modX == modY of in case x == y || modX == modY of
True -> c -- do case x' or y' are Nothing True -> c -- do case x' or y' are Nothing
False -> let c' = updateWith c f (x,modX) (y,modY) False -> let c' = updateWith c f x modX y modY
in case score c' >= currentScore of in case score c' >= currentScore of
True -> c' True -> c'
False -> c False -> c
updateWith :: Clustering Node updateWith :: Clustering Node
-> (Int -> Int -> Double) -> (Int -> Int -> Double)
-> (Int,Int) -> Int -> Int
-> (Int,Int) -> Int -> Int
-> Clustering Node -> Clustering Node
updateWith c@(ClusteringIs parts idx _ _) f (x,modX) (y,modY) = -- traceShow ("score", x,y,score') $ updateWith c@(ClusteringIs parts idx _ _) f x modX y modY = trace "updateWith" -- traceShow ("score", x,y,score') $
ClusteringIs parts' idx' score' Part ClusteringIs parts' idx' score' Part
where where
parts' = Dict.filter (not . Set.null) parts' = Dict.filter (not . Set.null)
...@@ -319,12 +357,21 @@ updateWith c@(ClusteringIs parts idx _ _) f (x,modX) (y,modY) = -- traceShow ("s ...@@ -319,12 +357,21 @@ updateWith c@(ClusteringIs parts idx _ _) f (x,modX) (y,modY) = -- traceShow ("s
px = Dict.elems parts' px = Dict.elems parts'
score' = Prelude.sum $ List.concat score' = getSum $
$ map (\s -> [ if x'' < y'' then f x'' y'' else 0 -- to Validate with BG foldMap (\s -> fold [ Sum (f x'' y'')
| x'' <- Set.toList s | x'' <- Set.toList s
, y'' <- Set.toList s , y'' <- Set.toList s
] , x'' < y''
) px ]
) parts'
-- Prelude.sum $ List.concatMap
-- (\s -> [ f x'' y'' -- to Validate with BG
-- | x'' <- Set.toList s
-- , y'' <- Set.toList s
-- , x'' < y''
-- ]
-- ) px
--------------------------------------------------------------- ---------------------------------------------------------------
make_clust_part :: forall n make_clust_part :: forall n
...@@ -332,8 +379,8 @@ make_clust_part :: forall n ...@@ -332,8 +379,8 @@ make_clust_part :: forall n
=> SortedEdges => SortedEdges
-> SimilarityMatrix n -> SimilarityMatrix n
-> Clustering Node -> Clustering Node
make_clust_part se sm = foldl' (\c (e1,e2,_) make_clust_part se sm = trace "make_clust_part" $ foldl' (\c (e1,e2,_)
-> updateClustering c -> {- trace ("foldl' step: " ++ show (e1, e2)) $ -} updateClustering c
(\x y -> 2 * (coeffDM x y sm')) (\x y -> 2 * (coeffDM x y sm'))
e1 e2 e1 e2
) (ClusteringIs parts idx 0 Part) se ) (ClusteringIs parts idx 0 Part) se
...@@ -398,7 +445,7 @@ instance KnownNat n => Symmetry (MatrixS n) where ...@@ -398,7 +445,7 @@ instance KnownNat n => Symmetry (MatrixS n) where
symmetry = symmetryS symmetry = symmetryS
symmetryD :: KnownNat n => MatrixD n -> MatrixD n symmetryD :: KnownNat n => MatrixD n -> MatrixD n
symmetryD m = DMatrix.imap (\x y v -> if x < y then v else coeffDM y x m) m symmetryD m = DMatrix.imapL (\(x, y) v -> if x < y then v else coeffDM y x m) m
symmetryS :: KnownNat n => MatrixS n -> MatrixS n symmetryS :: KnownNat n => MatrixS n -> MatrixS n
symmetryS m = SMatrix.imap (\x y v -> if x < y then v else coeffSM y x m) m symmetryS m = SMatrix.imap (\x y v -> if x < y then v else coeffSM y x m) m
...@@ -421,21 +468,30 @@ vectorFromListS pn ns ...@@ -421,21 +468,30 @@ vectorFromListS pn ns
n = natVal pn n = natVal pn
vectorFromListD :: KnownNat n => Proxy n -> [(Integer, Double)] -> VectorD n vectorFromListD :: KnownNat n => Proxy n -> [(Integer, Double)] -> VectorD n
vectorFromListD pn ns = toMatrix $ vectorFromListS pn ns vectorFromListD pn ns = SMatrix.densify $ vectorFromListS pn ns
------------------------------ ------------------------------
data Direction = Ligne | Colonne data Direction = Ligne | Colonne
sumWith :: ( Elem a sumWith
, Elem t :: (UV.Unbox a, UV.Unbox t, KnownNat n, Num t, HasCallStack, Show t)
, KnownNat n => Direction -> (t -> a) -> SMatrix.Matrix n n t -> SV.V n a
) => Direction -> (t -> a) -> SparseMatrix n n t -> VS.Vector a sumWith dir f m = SV.map f $
sumWith dir f m = VS.fromList case dir of
$ map (\v -> f v) Colonne -> SV.sum $ SMatrix.getCols m
$ case dir of Ligne -> SV.sum $ SMatrix.getRows m
Colonne -> somme $ SMatrix.getCols m
Ligne -> somme $ SMatrix.getRows m
where
somme m' = map (sum . SMatrix.toMatrix) m'
-------------------------------------------- --------------------------------------------
natToInt :: forall (n :: Nat). KnownNat n => Int
natToInt = fromIntegral $ natVal (Proxy :: Proxy n)
coeffSM
:: (Num a, UV.Unbox a, Show a)
=> Int -> Int -> SMatrix.Matrix n p a -> a
coeffSM i j m = SMatrix.extractCol m j SV.! i
coeffDM
:: (Num a, KnownNat n, KnownNat p)
=> Int -> Int -> DMatrix.L n p -> Double
coeffDM i j m = m `DMatrix.at` (i, j)
...@@ -22,7 +22,6 @@ import Data.Vector hiding (map, uniq) ...@@ -22,7 +22,6 @@ import Data.Vector hiding (map, uniq)
import Prelude (read) import Prelude (read)
import Protolude import Protolude
import Graph.Types import Graph.Types
import qualified Eigen.SparseMatrix as SMatrix
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Graph.Inductive as DGI import qualified Data.Graph.Inductive as DGI
......
{-# LANGUAGE TypeApplications #-}
{-| Module : Graph.Tools {-| Module : Graph.Tools
Description : Description :
Copyright : (c) CNRS, Alexandre Delanoë Copyright : (c) CNRS, Alexandre Delanoë
...@@ -25,7 +26,7 @@ import Graph.Types ...@@ -25,7 +26,7 @@ import Graph.Types
import Graph.Tools.Random import Graph.Tools.Random
import Graph.Tools.CSV import Graph.Tools.CSV
import Graph.FGL import Graph.FGL
import qualified Eigen.SparseMatrix as SMatrix import qualified Data.Matrix.Sparse.Static as SMatrix
import qualified Data.IntMap as Dict import qualified Data.IntMap as Dict
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
...@@ -44,7 +45,7 @@ data GraphData = LightGraph { lightGraph :: Graph () () } ...@@ -44,7 +45,7 @@ data GraphData = LightGraph { lightGraph :: Graph () () }
getGraph :: GetGraph -> IO GraphData getGraph :: GetGraph -> IO GraphData
getGraph Random = randomAdjacency getGraph Random = randomAdjacency @100
>>= \m -> pure $ LightGraph >>= \m -> pure $ LightGraph
$ mkGraphUfromEdges $ mkGraphUfromEdges
$ List.map (\(x,y,_) -> (x,y)) $ List.map (\(x,y,_) -> (x,y))
......
...@@ -6,7 +6,6 @@ Maintainer : alexandre+dev@delanoe.org ...@@ -6,7 +6,6 @@ Maintainer : alexandre+dev@delanoe.org
Stability : experimental Stability : experimental
Portability : POSIX Portability : POSIX
-} -}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
...@@ -22,18 +21,21 @@ import Data.Vector hiding (map, uniq) ...@@ -22,18 +21,21 @@ import Data.Vector hiding (map, uniq)
import Prelude (read) import Prelude (read)
import Protolude import Protolude
import Graph.Types import Graph.Types
import qualified Eigen.SparseMatrix as SMatrix -- import qualified Eigen.SparseMatrix as SMatrix
import qualified Eigen.Matrix as DMatrix -- import qualified Eigen.Matrix as DMatrix
import qualified Data.Graph.Inductive.PatriciaTree as DGIP import qualified Data.Graph.Inductive.PatriciaTree as DGIP
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import qualified Data.Matrix.Sparse.Static as SMatrix
import qualified Numeric.LinearAlgebra.Static as DMatrix
-- Random Matrix -- Random Matrix
-- | Random Matrix && Graph -- | Random Matrix && Graph
-- TODO random matrix of any size for the tests -- TODO random matrix of any size for the tests
randomMatrix :: IO (MatrixD 100) randomMatrix :: KnownNat n => IO (MatrixD n)
randomMatrix = DMatrix.random randomMatrix = DMatrix.rand
{- {-
matrix2graph :: forall n matrix2graph :: forall n
...@@ -44,10 +46,12 @@ matrix2graph m = withG (mkGraphUfromEdges $ map (\(x,y,_) -> (x,y)) $ SMatrix.to ...@@ -44,10 +46,12 @@ matrix2graph m = withG (mkGraphUfromEdges $ map (\(x,y,_) -> (x,y)) $ SMatrix.to
identity identity
-} -}
randomAdjacency :: IO (MatrixS 100) randomAdjacency :: KnownNat n => IO (MatrixS n)
randomAdjacency = do randomAdjacency = do
m1 <- randomMatrix m1 <- randomMatrix
m2 <- randomMatrix m2 <- randomMatrix
pure $ SMatrix.fromMatrix pure $ SMatrix.sparsify (\(i, j) v -> if i < j && v > 0.9 then Just 1 else Nothing)
$ DMatrix.imap (\i j v -> if i < j && v > 0.9 then 1 else 0)
$ DMatrix.mul m1 m2 $ DMatrix.mul m1 m2
-- pure $ SMatrix.fromMatrix
-- $ DMatrix.imapL (\(i, j) v -> if i < j && v > 0.9 then 1 else 0)
-- $ DMatrix.mul m1 m2
...@@ -15,8 +15,12 @@ module Graph.Types where ...@@ -15,8 +15,12 @@ module Graph.Types where
import qualified Data.Graph.Inductive.PatriciaTree as DGIP import qualified Data.Graph.Inductive.PatriciaTree as DGIP
import Data.IntMap (IntMap) import Data.IntMap (IntMap)
import qualified Eigen.Matrix as DenseMatrix -- import qualified Eigen.Matrix as DenseMatrix
import Eigen.SparseMatrix (SparseMatrix) -- import Eigen.SparseMatrix (SparseMatrix)
import qualified Data.Matrix.Sparse.Static as Sparse
import qualified Data.Vector.Unboxed as VU
import qualified Numeric.LinearAlgebra.Static as Dense
-- | Main Types use in this libray -- | Main Types use in this libray
...@@ -26,8 +30,5 @@ type Dict = IntMap ...@@ -26,8 +30,5 @@ type Dict = IntMap
type Graph a b = DGIP.Gr a b type Graph a b = DGIP.Gr a b
-- | Type for Matrix computation optimizations (with Eigen) -- | Type for Matrix computation optimizations (with Eigen)
type MatrixD n = DenseMatrix.Matrix n n Double type MatrixD n = Dense.L n n
type MatrixS n = SparseMatrix n n Double type MatrixS n = Sparse.Matrix n n Double
...@@ -44,8 +44,16 @@ extra-deps: ...@@ -44,8 +44,16 @@ extra-deps:
commit: f5c0e0071ec7b6532f9a9cd3eb33d14f340fbcc9 commit: f5c0e0071ec7b6532f9a9cd3eb33d14f340fbcc9
- git: https://gitlab.iscpif.fr/anoe/accelerate-utility.git - git: https://gitlab.iscpif.fr/anoe/accelerate-utility.git
commit: 83ada76e78ac10d9559af8ed6bd4064ec81308e4 commit: 83ada76e78ac10d9559af8ed6bd4064ec81308e4
- git: https://github.com/alpmestan/sparse-linear.git
commit: 785f12c99615907b207f5499dd3b70a486a0249b
subdirs:
- sparse-linear
- git: https://github.com/alpmestan/hmatrix.git
commit: 39155c60c97ba8cd5c8ab9c202b428fec42faa3c
subdirs:
- packages/base
- accelerate-arithmetic-1.0.0.1@sha256:555639232aa5cad411e89247b27871d09352b987a754230a288c690b6de6d888,2096 - accelerate-arithmetic-1.0.0.1@sha256:555639232aa5cad411e89247b27871d09352b987a754230a288c690b6de6d888,2096
- eigen-3.3.7.0@sha256:7c24a86426b238e02ba0ac2179cc44997518b443a13828ed7a791fe49a6dffa5,82060 # - eigen-3.3.7.0@sha256:7c24a86426b238e02ba0ac2179cc44997518b443a13828ed7a791fe49a6dffa5,82060
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
...@@ -64,7 +72,6 @@ extra-deps: ...@@ -64,7 +72,6 @@ extra-deps:
# Override the architecture used by stack, especially useful on Windows # Override the architecture used by stack, especially useful on Windows
# arch: i386 # arch: i386
# arch: x86_64 # arch: x86_64
#
# Extra directories used by stack for building # Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir] # extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir]
......
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