Merge branch 'clusternode-eq-instance' into 'master'

Align side branch with main master

See merge request !2

gargantext-graph.cabal

 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.34.7.
 --
 -- see: https://github.com/sol/hpack
 
@@ -71,43 +71,6 @@ library
     , vector
   default-language: Haskell2010
 
-executable gargantext-graph-exe
-  main-is: Main.hs
-  other-modules:
-      Paths_gargantext_graph
-  hs-source-dirs:
-      app
-  default-extensions:
-      DataKinds
-      FlexibleInstances
-      OverloadedStrings
-  ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N -fprof-auto -Wmissing-signatures -Wcompat
-  build-depends:
-      accelerate
-    , accelerate-arithmetic
-    , accelerate-utility
-    , base >=4.7 && <5
-    , bytestring
-    , cassava
-    , cereal
-    , containers
-    , criterion
-    , eigen
-    , fgl
-    , gargantext-graph
-    , haskell-igraph >=0.6.0
-    , hmatrix
-    , lens
-    , pretty-simple
-    , protolude
-    , reflection
-    , singletons
-    , sparse-linear
-    , string-conversions
-    , text
-    , vector
-  default-language: Haskell2010
-
 test-suite gargantext-graph-test
   type: exitcode-stdio-1.0
   main-is: Main.hs

nix/pinned-20.09.nix

+# this version of nixpkgs contains liblapack at ?
+# this version of nixpkgs contains gsl at ?
+import (builtins.fetchGit {
+  # Descriptive name to make the store path easier to identify
+  name = "nixos-20.09";
+  url = "https://github.com/nixos/nixpkgs/";
+  # `git ls-remote https://github.com/nixos/nixpkgs-channels nixos-20.09`
+  ref = "refs/heads/nixos-20.09";
+  rev = "69f3a9705014ce75b0489404210995fb6f29836e";
+})

nix/pinned-21.05.nix

+import (builtins.fetchGit {
+  name = "nixos-21.05";
+  url = "https://github.com/nixos/nixpkgs";
+  ref = "refs/heads/nixos-21.05";
+  rev = "7e9b0dff974c89e070da1ad85713ff3c20b0ca97";
+})

nix/pinned-22.05.nix

+import (builtins.fetchGit {
+  name = "nixos-22.05";
+  url = "https://github.com/nixos/nixpkgs";
+  ref = "refs/heads/nixos-22.05";
+  rev = "7e9b0dff974c89e070da1ad85713ff3c20b0ca97";
+})

nix/pkgs.nix

+{ pkgs ? import ./pinned-22.05.nix {} }:
+
+rec {
+  inherit pkgs;
+  ghc = pkgs.haskell.compiler.ghc8104;
+  hsBuildInputs = [
+    ghc
+    pkgs.cabal-install
+  ];
+  nonhsBuildInputs = with pkgs; [
+    bzip2
+    czmq
+    docker-compose
+    git
+    gmp
+    gsl
+    #haskell-language-server
+    hlint
+    igraph
+    libffi
+    liblapack
+    lzma
+    pcre
+    pkgconfig
+    postgresql
+    xz
+    zlib
+    blas
+    gfortran7
+    #    gfortran7.cc.lib
+    expat
+    icu
+    graphviz
+    llvm_9
+  ];
+  libPaths = pkgs.lib.makeLibraryPath nonhsBuildInputs;
+  shellHook = ''
+    export LD_LIBRARY_PATH="${pkgs.gfortran7.cc.lib}:${libPaths}:$LD_LIBRARY_PATH"
+    export LIBRARY_PATH="${pkgs.gfortran7.cc.lib}:${libPaths}"
+  '';
+  shell = pkgs.mkShell {
+    name = "gargantext-shell";
+    buildInputs = hsBuildInputs ++ nonhsBuildInputs;
+    inherit shellHook;
+  };
+}

nix/shell.nix

+(import ./pkgs.nix {}).shell

nix/stack-shell.nix

+let ourpkgs = import ./pkgs.nix {};
+    pkgs = ourpkgs.pkgs;
+in
+pkgs.haskell.lib.buildStackProject rec {
+  name = "gargantext";
+  ghc = ourpkgs.ghc;
+  buildInputs = ourpkgs.nonhsBuildInputs;
+  shellHook = ourpkgs.shellHook;
+}

package.yaml

@@ -50,21 +50,21 @@ default-extensions:
 library:
   source-dirs: src
 
-executables:
-  gargantext-graph-exe:
-    main:                Main.hs
-    source-dirs:         app
-    ghc-options:
-    - -O2
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -fprof-auto
-    - -Wmissing-signatures
-    - -Wcompat
-    dependencies:
-    - gargantext-graph
-    - criterion
+# executables:
+#   gargantext-graph-exe:
+#     main:                Main.hs
+#     source-dirs:         app
+#     ghc-options:
+#     - -O2
+#     - -threaded
+#     - -rtsopts
+#     - -with-rtsopts=-N
+#     - -fprof-auto
+#     - -Wmissing-signatures
+#     - -Wcompat
+#     dependencies:
+#     - gargantext-graph
+#     - criterion
 
 tests:
   gargantext-graph-test:

src/Data/Array/Accelerate/Utils.hs

@@ -134,7 +134,7 @@ condOrDefault
 condOrDefault theCond def x = permute const zeros filterInd x
   where 
     zeros = fill (shape x) (def)
-    filterInd ix = (cond (theCond ix)) (Just_ ix) Nothing_
+    filterInd ix = cond (theCond ix) (Just_ ix) Nothing_
 
 -----------------------------------------------------------------------
 _runExp :: Elt e => Exp e -> e
@@ -308,7 +308,7 @@ sumRowMin n m = {-trace (P.show $ run m') $-} m'
        $ P.map (\z -> sumRowMin1 n (constant z) m) [0..n-1]
 
 sumRowMin1 :: (Num a, Ord a) => Dim -> Exp Int -> Acc (Matrix a) -> Acc (Vector a)
-sumRowMin1 n x m = {- trace (P.show (run m,run $ transpose m)) $ -} m''
+sumRowMin1 n x m = m''
   where
     m'' = sum $ zipWith min (transpose m) m
     _m'  = zipWith (*) (zipWith (*) (nullOf n (MatCol x)) $ nullOfWithDiag n (MatRow x)) m

src/Graph/BAC/ProxemyOptim.hs

-{-# LANGUAGE BangPatterns #-}
 {-| Module      : Gargantext.Core.Viz.Graph.ProxemyOptim
 Description : Proxemy
 Copyright   : (c) CNRS, 2017-Present
@@ -13,9 +12,6 @@ see above)
 
 Article: Confluence for Graph Clustering, B. Gaume and A. Delanoë, A. Mestanogullari
 
-Code written in Haskell by A. Delanoë from first Python Specifications by B.
-Gaume.
-
 -}
 
 {-# LANGUAGE FlexibleContexts
@@ -29,6 +25,7 @@ Gaume.
            , NoImplicitPrelude
            , RankNTypes
            , MultiParamTypeClasses
+           , BangPatterns
 #-}
 
 {-# LANGUAGE AllowAmbiguousTypes #-}
@@ -40,6 +37,7 @@ import Data.IntMap (IntMap)
 import Data.Maybe (isJust, fromJust)
 import Data.Proxy (Proxy(Proxy))
 import Data.Reflection
+import Data.Semigroup
 import GHC.TypeLits (KnownNat, Nat, SomeNat(SomeNat), type(+), natVal, sameNat, someNatVal)
 import Graph.FGL
 import Graph.Types
@@ -68,10 +66,26 @@ import qualified Data.Map.Strict as Map
 
 ----------------------------------------------------------------
 
+traceMaxIndices :: forall a t. (Bounded t, Ord t, Show t) => String -> [t] -> a -> a
+traceMaxIndices f xs a = trace s a
+
+  where s = "[" ++ f ++ "] (min, max, # of ints) = " ++ show (min_i, max_i, Set.size is)
+        (min_i, max_i, is) = foldl'
+          (\(s, b, ints) i -> (min s i, max b i, Set.insert i ints))
+          (maxBound :: t, minBound :: t, Set.empty)
+          xs
+
+traceAdjMapIndices :: String -> Map (Int, Int) x -> a -> a
+traceAdjMapIndices f m a = traceMaxIndices f (foldMap (\(a, b) -> [a, b]) (Map.keys m)) a
+
+traceDicoIndices :: (Ord x, Show x, Bounded x) => String -> IntMap x -> a -> a
+traceDicoIndices s m a = traceMaxIndices (s ++ " dico keys => ") (Dict.keys m) $
+  traceMaxIndices (s ++ " dico vals => ") (Dict.elems m) a
+
 defaultClustering :: Map (Int, Int) Double -> [ClusterNode]
 defaultClustering adjmap = withG g $ \fg ->
-  case clusteringOptim len fg beta gc of
-    Clust _ dico idx _ -> map (lkpId dico) (Dict.toList idx)
+  case clusteringOptim len fg dicoToId beta gc of
+    Clust _ idx _ -> map go (Dict.toList idx)
 
   where gc = False
         beta = 0.0
@@ -79,30 +93,34 @@ defaultClustering adjmap = withG g $ \fg ->
         g = DGI.mkGraph ns es
         ns = zip [0..] . Set.toList . Set.fromList $
           concatMap (\(a, b) -> [a, b]) $ Map.keys adjmap
-        es = map (\((a, b), w) -> (a, b, w)) $ Map.toList adjmap
-        lkpId dict (i, clust) = ClusterNode
-          (fromJust (Dict.lookup i dict))
+        lkpId n = dicoToId Dict.! n
+        lkpLbl n = dicoToLbl Dict.! n
+        dicoToId = Dict.fromList (map (\(a, b) -> (b, a)) ns)
+        dicoToLbl = Dict.fromList ns
+        es = map (\((a, b), w) -> (lkpId a, lkpId b, w)) $ Map.toList adjmap
+        go (i, clust) = ClusterNode
+          (lkpLbl i)
           clust
 
 {-# INLINE clusteringOptim #-}
-clusteringOptim :: forall n a b. KnownNat n
+clusteringOptim :: forall n a b. (KnownNat n, Ord a, Show a, Bounded a)
                 => Length            -- ^ length of the random walks
                 -> FiniteGraph n a b -- ^ graph to compute clusters for
+                -> Dict a
                 -> Double            -- ^ beta
                 -> Bool              -- ^ True = run GC, False = don't
                 -> Clust a
-clusteringOptim l fg@(FiniteGraph g) beta gc = trace ("clusteringOptim" :: String) $
+clusteringOptim l fg@(FiniteGraph g) dico beta gc =
   case runClustering gc beta adj prox sorted_edges of
-    (clusts, d) -> Clust clusts dico (index clusts) d
+    (clusts, d) -> Clust clusts (index clusts) d
   where
-    dico = trace ("dico" :: String) $ Dict.fromList (DGI.labNodes g)
-    index clusts = trace ("index" :: String) $ Dict.foldMapWithKey
+    index clusts = Dict.foldMapWithKey
       (\clustN is -> Dict.fromList $ map (,clustN) (IntSet.toList is))
       clusts
-    !adj = graphMatrix fg True
-    !tra = transition adj
-    !prox = proxemie l tra
-    sorted_edges = trace ("confluence" :: String) $ sort_edges (natToInt @n) (edges_confluence l fg adj tra)
+    adj = graphMatrix fg True
+    tra = transition adj
+    prox = proxemie l tra
+    sorted_edges = sort_edges (natToInt @n) (edges_confluence l fg adj tra)
 
 graphMatrix
   :: forall (n :: Nat) a b.
@@ -110,17 +128,16 @@ graphMatrix
   => FiniteGraph n a b -> Bool -> SMatrix.Matrix n n Double
 graphMatrix (FiniteGraph g) reflexive = adj
   where
-    !adj = trace ("adjacency" :: String) $ SMatrix.fromList es
+    adj = SMatrix.fromList es
     es = diag ++ triplets
     triplets = [ (i, j, 1.0) | i <- nodes g, j <- neighbors g i ]
     diag     = if reflexive
-               then [ (i, i, 1.0) | i <- [0..(n-1)] ]
+               then [ (i, i, 1.0) | i <- nodes g ]
                else []
-    n        = fromIntegral $ natVal (Proxy :: Proxy n)
 
 transition
   :: KnownNat n => SMatrix.Matrix n n Double -> SMatrix.Matrix n n Double
-transition m = trace ("transition" :: String) $ SMatrix.imap
+transition m = SMatrix.imap
   (\i j _ -> 1 / fromIntegral (SMatrix.nnzCol m j))
   m
 
@@ -159,10 +176,9 @@ proxemie :: KnownNat n
          => Length
          -> SMatrix.Matrix n n Double
          -> ProxemyMatrix n
-proxemie l !tm = trace ("proxemie" :: String) $ case l <= 1 of
+proxemie l !tm = case l <= 1 of
   True  -> tm
-  False -> case iterate (SMatrix.mul tm) tm Prelude.!! (l-1) of
-    !p -> trace ("proxemie ok" :: String) p
+  False -> iterate (SMatrix.mul tm) tm Prelude.!! (l-1)
 
 ---------------------------------------------------------------
 matconf :: forall n. KnownNat n
@@ -219,6 +235,54 @@ type SortedEdges   = [(Node, Node, Double)]
 
 type X = Edge
 
+-- | Just compute the confluences of a list of edges
+computeConfluences
+  :: Length -- ^ length of the random walk
+  -> [(Int, Int)] -- ^ list of edges
+  -> Bool -- ^ reflexive?
+  -> Map (Int, Int) Double
+computeConfluences l edges reflexive = reifyNat (fromIntegral maxNode + 1) $ \(Proxy :: Proxy n) ->
+  let
+    nodeLabels = Set.toList $ Set.fromList $ foldMap (\(a, b) -> [a, b]) edges
+    dictLabels = Dict.fromList (zip [0..] nodeLabels)
+    dictIDs    = Dict.fromList (zip nodeLabels [0..])
+    edges'     = map (\(a, b) -> (dictIDs Dict.! a, dictIDs Dict.! b)) edges
+    xs :: [(Int, Int, Double)]
+    xs =
+      concatMap (\(i, j) -> [(i, j, 1.0), (j, i, 1.0)]) edges' ++
+      (if reflexive
+        then [ (i, i, 1.0) | i <- [0..(Dict.size dictLabels - 1)] ]
+        else []
+      )
+    am :: SMatrix.Matrix n n Double
+    am = SMatrix.fromList xs
+    tm = transition am
+    sumdeg_m2 = fromIntegral (SMatrix.nonZeros am - 2)
+    go x y =
+      let
+        !deg_x_m1 = fromIntegral (SMatrix.nnzCol am x - 1)
+        !deg_y_m1 = fromIntegral (SMatrix.nnzCol am y - 1)
+        v         = SMatrix.asColumn (SVector.singleton y 1)
+        v'        =
+          SMatrix.withColChangeExcept x (1/deg_x_m1) y tm $ \tm' ->
+            SMatrix.withColChangeExcept y (1/deg_y_m1) x tm' $ \tm'' ->
+              iterate (SMatrix.mul tm'') v Prelude.!! l
+        prox_y_x_length = SMatrix.extractCol v' 0 SVector.! x
+        prox_y_x_infini = if sumdeg_m2 == 0 then 0 else deg_x_m1 / sumdeg_m2
+        denominator = (prox_y_x_length + prox_y_x_infini)
+      in
+        if denominator == 0
+           then 0
+           else (prox_y_x_length - prox_y_x_infini) / denominator
+  in
+    Map.fromList $ map
+      (\(a, b) -> ( (a, b)
+                  , go (dictIDs Dict.! a) (dictIDs Dict.! b)
+                  )
+      ) edges
+
+  where maxNode = getMax $ foldMap (\(i, j) -> Max (max i j)) edges
+
 edges_confluence :: forall n a b.
                     KnownNat n
                  => Length
@@ -226,7 +290,7 @@ edges_confluence :: forall n a b.
                  -> SMatrix.Matrix n n Double -- adjacency
                  -> SMatrix.Matrix n n Double -- transition
                  -> UnsortedEdges
-edges_confluence l (FiniteGraph g) am tm = trace ("confluence" :: String) $ map f (edges g)
+edges_confluence l (FiniteGraph g) am tm = map f (edges g)
 
   where
       vcount    = natToInt @n
@@ -239,7 +303,7 @@ edges_confluence l (FiniteGraph g) am tm = trace ("confluence" :: String) $ map
               v'        =
                 SMatrix.withColChangeExcept x (1/deg_x_m1) y tm $ \tm' ->
                   SMatrix.withColChangeExcept y (1/deg_y_m1) x tm' $ \tm'' ->
-                    iterate (SMatrix.mul tm'') v Prelude.!! 3
+                    iterate (SMatrix.mul tm'') v Prelude.!! l
               prox_y_x_length = SMatrix.extractCol v' 0 SVector.! x
               prox_y_x_infini = deg_x_m1 / sumdeg_m2
               conf  = (prox_y_x_length - prox_y_x_infini) / (prox_y_x_length + prox_y_x_infini)
@@ -248,7 +312,7 @@ edges_confluence l (FiniteGraph g) am tm = trace ("confluence" :: String) $ map
 sort_edges :: Int
            -> UnsortedEdges
            -> SortedEdges
-sort_edges n = trace ("sort_edges" :: String) . List.sortBy (\a b -> confCompare a b <> comparing xnpy a b)
+sort_edges n = List.sortBy (\a b -> confCompare a b <> comparing xnpy a b)
   where
     third
       :: forall a b c
@@ -293,7 +357,7 @@ data MClustering s =
               }
 
 newMClustering :: Int -> ST s (MClustering s)
-newMClustering n = trace ("newClustering" :: String) $ do
+newMClustering n = do
   mps <- MV.unsafeNew n
   mis <- MVU.unsafeNew n
   msc <- MVU.unsafeNew 1
@@ -427,7 +491,6 @@ clusteringCollector beta adj prox mclust = do
 
 data Clust a = Clust
   { cparts :: !(Dict IntSet)
-  , cdico  :: (Dict a)
   , cindex :: (Dict Int)
   , cscore :: !Double
   } deriving (Show, Eq)
@@ -440,11 +503,11 @@ runClustering
   -> SMatrix.Matrix n n Double -- ^ proxemie
   -> SortedEdges
   -> (Dict IntSet, Double)
-runClustering gc beta adj prox se = trace ("runClustering" :: String) $ runST $ do
+runClustering gc beta adj prox se = runST $ do
   mclust <- newMClustering n
-  trace ("hbec" :: String) $ forM_ se $ \(x, y, _) -> clusteringStep beta adj prox mclust (x, y)
+  forM_ se $ \(x, y, _) -> clusteringStep beta adj prox mclust (x, y)
   if gc
-    then trace ("gc" :: String) $ clusteringCollector beta adj prox mclust
+    then clusteringCollector beta adj prox mclust
     else do cps <- V.unsafeFreeze (mparts mclust)
             let cps' = Dict.fromList
                   [ (n, xs)

src/Graph/Types.hs

@@ -40,4 +40,5 @@ data ClusterNode = ClusterNode
   , cl_community_id :: Int
   } deriving Show
 
-
+instance Eq ClusterNode where
+  ClusterNode n1 c1 == ClusterNode n2 c2 = (n1 == n2) && (c1 == c2)

stack.yaml

-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-
 resolver:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/10.yaml
-allow-newer: true
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-#   subdirs:
-#   - auto-update
-#   - wai
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml
+flags:
+    accelerate:
+        debug: false
+extra-package-dbs: []
+skip-ghc-check: true
 packages:
 - .
-  #- '../eigen/'
-  # Dependency packages to be pulled from upstream that are not in the resolver.
-# These entries can reference officially published versions as well as
-# forks / in-progress versions pinned to a git hash. For example:
-#
+
+docker:
+  enable: false
+  #enable: true
+  repo: 'cgenie/stack-build:lts-18.18-garg'
+  #repo: 'cgenie/nixos-stack:latest'
+
+skip-ghc-check: true
+
+nix:
+  enable: false
+  add-gc-roots: true
+  shell-file: nix/stack-shell.nix
+
+allow-newer: true
+
 extra-deps:
-- git: https://github.com/kaizhang/haskell-igraph.git
-  commit: d790e030e6e08b04dc0971221b6054d6700d82e7
-- git: https://gitlab.iscpif.fr/anoe/accelerate.git
-  commit: f5c0e0071ec7b6532f9a9cd3eb33d14f340fbcc9
-- git: https://gitlab.iscpif.fr/anoe/accelerate-utility.git
-  commit: 83ada76e78ac10d9559af8ed6bd4064ec81308e4
+- git: https://github.com/alpmestan/haskell-igraph.git
+  commit: 9f55eb36639c8e0965c8bc539a57738869f33e9a
+- git: https://github.com/alpmestan/accelerate.git
+  commit: 640b5af87cea94b61c7737d878e6f7f2fca5c015
+- git: https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git
+  commit: a3875fe652d3bb5acb522674c22c6c814c1b4ad0
 - git: https://github.com/alpmestan/sparse-linear.git
   commit: bc6ca8058077b0b5702ea4b88bd4189cfcad267a
   subdirs:
@@ -52,7 +38,8 @@ extra-deps:
   commit: b9fca8beee0f23c17a6b2001ec834d071709e6e7
   subdirs:
     - packages/base
-- accelerate-arithmetic-1.0.0.1@sha256:555639232aa5cad411e89247b27871d09352b987a754230a288c690b6de6d888,2096
+- git: https://github.com/alpmestan/accelerate-arithmetic.git
+  commit: a110807651036ca2228a76507ee35bbf7aedf87a
 - eigen-3.3.7.0@sha256:7c24a86426b238e02ba0ac2179cc44997518b443a13828ed7a791fe49a6dffa5,82060
 
 - vector-0.12.3.0
@@ -61,26 +48,7 @@ ghc-options:
   sparse-linear: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
   gargantext-graph: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
 
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=2.5"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
+ghc-options:
+  hmatrix: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
+  sparse-linear: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack
+  gargantext-graph: -O2 -fsimpl-tick-factor=10000 -fdicts-cheap -fdicts-strict -flate-dmd-anal  -fno-state-hack