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