src/Gargantext/Viz/Graph/Tools.hs

   1 {-|
   2 Module      : Gargantext.Viz.Graph.Tools
   3 Description : Tools to build Graph
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE NoImplicitPrelude           #-}
  13 {-# LANGUAGE OverloadedStrings           #-}
  14
  15 module Gargantext.Viz.Graph.Tools
  16   where
  17
  18 import Control.Monad.IO.Class (liftIO)
  19 import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
  20 import Debug.Trace (trace)
  21 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
  22 import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
  23 import Data.Map (Map)
  24 import qualified Data.Set as Set
  25 import Data.Text (Text)
  26 import Gargantext.Prelude
  27 import Gargantext.Core.Statistics
  28 import Gargantext.Viz.Graph
  29 import Gargantext.Viz.Graph.Bridgeness (bridgeness)
  30 import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
  31 import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index)
  32 import Gargantext.Viz.Graph.IGraph (mkGraphUfromEdges)
  33 import Gargantext.Viz.Graph.Proxemy (confluence)
  34 import GHC.Float (sin, cos)
  35 import qualified IGraph as Igraph
  36 import qualified IGraph.Algorithms.Layout as Layout
  37 import qualified Data.Vector.Storable as Vec
  38 import qualified Data.Map  as Map
  39 import qualified Data.List as List
  40
  41 type Threshold = Double
  42
  43
  44 cooc2graph' :: Ord t => Double
  45                      -> Map (t, t) Int
  46                      -> Map (Index, Index) Double
  47 cooc2graph' threshold myCooc = distanceMap
  48   where
  49     (ti, _) = createIndices myCooc
  50     myCooc' = toIndex ti myCooc
  51     matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
  52     distanceMat = measureConditional matCooc
  53     distanceMap = Map.filter (> threshold) $ mat2map distanceMat
  54
  55
  56 cooc2graph :: Threshold
  57            -> (Map (Text, Text) Int)
  58            -> IO Graph
  59 cooc2graph threshold myCooc = do
  60   let (ti, _) = createIndices myCooc
  61       myCooc' = toIndex ti myCooc
  62       matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
  63       distanceMat = measureConditional matCooc
  64       distanceMap = Map.filter (> threshold) $ mat2map distanceMat
  65
  66   let nodesApprox :: Int
  67       nodesApprox = n'
  68         where
  69           (as, bs) = List.unzip $ Map.keys distanceMap
  70           n' = Set.size $ Set.fromList $ as <> bs
  71       ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
  72
  73   partitionsV <- liftIO newEmptyMVar
  74   partitions' <- case Map.size distanceMap > 0 of
  75     True  -> trace ("level" <> show level) $ cLouvain level distanceMap
  76     False -> panic "Text.Flow: DistanceMap is empty"
  77
  78   _ <- liftIO $ forkIO $ putMVar partitionsV partitions'
  79   partitions <- liftIO $ takeMVar partitionsV
  80
  81   let bridgeness' = {-trace ("rivers: " <> show rivers) $-}
  82                     bridgeness rivers partitions distanceMap
  83
  84   let confluence' = confluence (Map.keys bridgeness') 3 True False
  85
  86   data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
  87
  88
  89 data ClustersParams = ClustersParams { bridgness :: Double
  90                                      , louvain   :: Text
  91                                      } deriving (Show)
  92
  93 clustersParams :: Int -> ClustersParams
  94 clustersParams x = ClustersParams (fromIntegral x) "0.00000001" -- y
  95   {- where
  96     y | x < 100  = "0.000001"
  97       | x < 350  = "0.000001"
  98       | x < 500  = "0.000001"
  99       | x < 1000 = "0.000001"
 100       | otherwise = "1"
 101  -}
 102
 103 ----------------------------------------------------------
 104 -- | From data to Graph
 105 data2graph :: [(Text, Int)]
 106            -> Map (Int, Int) Int
 107            -> Map (Int, Int) Double
 108            -> Map (Int, Int) Double
 109            -> [LouvainNode]
 110            -> IO Graph
 111 data2graph labels coocs bridge conf partitions = do
 112
 113     let community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
 114
 115     nodes <- mapM (setCoord ForceAtlas labels bridge)
 116           [ (n, Node { node_size = maybe 0 identity (Map.lookup (n,n) coocs)
 117                    , node_type = Terms -- or Unknown
 118                    , node_id    = cs (show n)
 119                    , node_label = l
 120                    , node_x_coord = 0
 121                    , node_y_coord = 0
 122                    , node_attributes =
 123                      Attributes { clust_default = maybe 0 identity
 124                                 (Map.lookup n community_id_by_node_id) } }
 125                )
 126             | (l, n) <- labels
 127             , Set.member n $ Set.fromList
 128                            $ List.concat
 129                            $ map (\((s,t),d) -> if d > 0 && s /=t then [s,t] else [])
 130                            $ Map.toList bridge
 131             ]
 132
 133     let edges = [ Edge { edge_source = cs (show s)
 134                        , edge_target = cs (show t)
 135                        , edge_weight =  d
 136                        , edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
 137                    -- , edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
 138                    , edge_id     = cs (show i) }
 139                    | (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
 140                    ]
 141
 142     pure $ Graph nodes edges Nothing
 143
 144 ------------------------------------------------------------------------
 145
 146 data Layout = KamadaKawai | ACP | ForceAtlas
 147
 148
 149 setCoord' :: (Int -> (Double, Double)) -> (Int, Node) -> Node
 150 setCoord' f (i,n) = n { node_x_coord = x, node_y_coord = y }
 151   where
 152     (x,y) = f i
 153
 154
 155 -- | ACP
 156 setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> IO Node
 157 setCoord l labels m (n,node) = getCoord l labels m n
 158                            >>= \(x,y) -> pure $ node { node_x_coord = x
 159                                                      , node_y_coord = y
 160                                                      }
 161
 162
 163 getCoord :: Ord a => Layout
 164                   -> [(a, Int)] -> Map (Int, Int) Double -> Int -> IO (Double, Double)
 165 getCoord KamadaKawai _ m n = layout m n
 166
 167 getCoord ForceAtlas _ _ n = pure (sin d, cos d)
 168   where
 169     d = fromIntegral n
 170
 171 getCoord ACP labels m n = pure $ to2d $ maybe (panic "Graph.Tools no coordinate") identity
 172              $ Map.lookup n
 173              $ pcaReduceTo (Dimension 2)
 174              $ mapArray labels m
 175   where
 176     to2d :: Vec.Vector Double -> (Double, Double)
 177     to2d v  = (x',y')
 178       where
 179         ds = take 2 $ Vec.toList v
 180         x'  = head' "to2d" ds
 181         y'  = last' "to2d" ds
 182
 183     mapArray :: Ord a => [(a, Int)] -> Map (Int, Int) Double -> Map Int (Vec.Vector Double)
 184     mapArray items m' = Map.fromList [ toVec n' ns m' | n' <- ns ]
 185       where
 186         ns = map snd items
 187
 188     toVec :: Int -> [Int] -> Map (Int,Int) Double -> (Int, Vec.Vector Double)
 189     toVec n' ns' m' = (n', Vec.fromList $ map (\n'' -> maybe 0 identity $ Map.lookup (n',n'') m') ns')
 190 ------------------------------------------------------------------------
 191
 192 -- | KamadaKawai Layout
 193 -- TODO TEST: check labels, nodeId and coordinates
 194 layout :: Map (Int, Int) Double -> Int -> IO (Double, Double)
 195 layout m n = maybe (panic "") identity <$> Map.lookup n <$> coord
 196   where
 197     coord :: IO (Map Int (Double,Double))
 198     coord = Map.fromList <$> List.zip (Igraph.nodes g) <$> (Layout.getLayout g p)
 199     --p = Layout.defaultLGL
 200     p = Layout.defaultKamadaKawai
 201     g = mkGraphUfromEdges $ map fst $ List.filter (\e -> snd e > 0) $ Map.toList m
 202