Merge branch 'dev-graph-async' into dev

src/Gargantext/API/Corpus/New.hs

@@ -67,7 +67,6 @@ data Query = Query { query_query      :: Text
 
 deriveJSON (unPrefix "query_") 'Query
 
-
 instance Arbitrary Query where
     arbitrary = elements [ Query q n fs
                          | q <- ["a","b"]
@@ -157,7 +156,6 @@ type Upload = Summary "Corpus Upload endpoint"
     :<|> "addWithquery" :> AsyncJobsAPI ScraperStatus                   WithQuery ScraperStatus
     :<|> "addWithfile"  :> AsyncJobs    ScraperStatus '[FormUrlEncoded] WithForm  ScraperStatus
 
-
 type AddWithQuery = Summary "Add with Query to corpus endpoint"
    :> "corpus"
    :> Capture "corpus_id" CorpusId
@@ -205,7 +203,6 @@ addToCorpusJobFunction _cid (WithQuery _q _dbs _l) logStatus = do
                           , _scst_events    = Just []
                           }
 
-
 addToCorpusWithFile :: FlowCmdM env err m
                     => CorpusId
                     -> MultipartData Mem

src/Gargantext/Core/Types.hs

@@ -12,8 +12,8 @@ commentary with @some markup@.
 -}
 
 ------------------------------------------------------------------------
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell      #-}
 
 module Gargantext.Core.Types ( module Gargantext.Core.Types.Main

src/Gargantext/Prelude.hs

@@ -323,5 +323,3 @@ inMVar f = do
   _ <- liftIO $ forkIO $ putMVar mVar zVar
   liftIO $ takeMVar mVar
 
-
-

src/Gargantext/Viz/Graph/API.hs

@@ -12,23 +12,28 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}   -- allows to write Text literals
 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
-{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TypeOperators     #-}
 
 module Gargantext.Viz.Graph.API
   where
 
--- import Debug.Trace (trace)
+import Debug.Trace (trace)
 import Control.Concurrent -- (forkIO)
 import Control.Lens (set, (^.), _Just, (^?))
 import Control.Monad.IO.Class (liftIO)
+import Data.Aeson
 import Data.Maybe (Maybe(..))
+import Data.Swagger
+import GHC.Generics (Generic)
+
 import Gargantext.API.Ngrams (NgramsRepo, r_version)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Types
@@ -45,6 +50,10 @@ import Gargantext.Prelude
 import Gargantext.Viz.Graph
 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
 import Servant
+
+import Gargantext.API.Orchestrator.Types
+import Servant.Job.Types
+import Servant.Job.Async
 import qualified Data.Map as Map
 
 ------------------------------------------------------------------------
@@ -54,12 +63,22 @@ import qualified Data.Map as Map
 type GraphAPI   =  Get  '[JSON] Graph
               :<|> Post '[JSON] [GraphId]
               :<|> Put  '[JSON] Int
+              :<|> GraphAsyncAPI
+              :<|> "versions" :> GraphVersionsAPI
+
 
+data GraphVersions = GraphVersions { gv_graph :: Maybe Int
+                                   , gv_repo :: Int } deriving (Show, Generic)
+
+instance ToJSON GraphVersions
+instance ToSchema GraphVersions
 
 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
 graphAPI u n =  getGraph  u n
          :<|> postGraph n
          :<|> putGraph  n
+         :<|> graphAsync u n
+         :<|> graphVersionsAPI u n
 
 ------------------------------------------------------------------------
 
@@ -78,6 +97,47 @@ getGraph' u n = do
 -}
 getGraph :: UserId -> NodeId -> GargNoServer Graph
 getGraph uId nId = do
+  nodeGraph <- getNodeWith nId HyperdataGraph
+  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+  -- let listVersion = graph ^? _Just
+  --                           . graph_metadata
+  --                           . _Just
+  --                           . gm_list
+  --                           . lfg_version
+
+  repo <- getRepo
+  -- let v = repo ^. r_version
+  nodeUser <- getNodeUser (NodeId uId)
+
+  let uId' = nodeUser ^. node_userId
+
+  let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
+                  identity
+                  $ nodeGraph ^. node_parentId
+
+  g <- case graph of
+    Nothing     -> do
+        graph' <- computeGraph cId NgramsTerms repo
+        _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
+        pure $ trace "Graph empty, computing" $ graph'
+
+    Just graph' -> pure $ trace "Graph exists, returning" $ graph'
+
+    -- Just graph' -> if listVersion == Just v
+    --                  then pure graph'
+    --                  else do
+    --                    graph'' <- computeGraph cId NgramsTerms repo
+    --                    _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
+    --                    pure graph''
+
+  newGraph  <- liftIO newEmptyMVar
+  _  <- liftIO $ forkIO $ putMVar newGraph g
+  g' <- liftIO $ takeMVar newGraph
+  pure {- $ trace (show g) $ -} g'
+
+
+recomputeGraph :: UserId -> NodeId -> GargNoServer Graph
+recomputeGraph uId nId = do
   nodeGraph <- getNodeWith nId HyperdataGraph
   let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
   let listVersion = graph ^? _Just
@@ -96,22 +156,23 @@ getGraph uId nId = do
                   identity
                   $ nodeGraph ^. node_parentId
 
-  newGraph  <- liftIO newEmptyMVar
   g <- case graph of
     Nothing     -> do
-      graph' <- inMVarIO $ computeGraph cId NgramsTerms repo
+      graph' <- computeGraph cId NgramsTerms repo
       _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
-      pure graph'
+      pure $ trace "[recomputeGraph] Graph empty, computing" $ graph'
 
     Just graph' -> if listVersion == Just v
                      then pure graph'
                      else do
                        graph'' <- computeGraph cId NgramsTerms repo
                        _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
-                       pure graph''
+                       pure $ trace "[recomputeGraph] Graph exists, recomputing" $ graph''
+
+  newGraph  <- liftIO newEmptyMVar
   _  <- liftIO $ forkIO $ putMVar newGraph g
   g' <- liftIO $ takeMVar newGraph
-  pure {- $ trace (show g) $ -} g'
+  pure g'
 
 
 -- TODO use Database Monad only here ?
@@ -129,12 +190,12 @@ computeGraph cId nt repo = do
   lIds <- selectNodesWithUsername NodeList userMaster
   let ngs = filterListWithRoot GraphTerm $ mapTermListRoot [lId] nt repo
 
-  myCooc <- Map.filter (>1)
-         <$> getCoocByNgrams (Diagonal True)
+  myCooc <- inMVarIO $ Map.filter (>1)
+         <$> getCoocByNgrams (Diagonal False)
          <$> groupNodesByNgrams ngs
          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 
-  graph <- liftIO $ inMVarIO $ cooc2graph 0 myCooc
+  graph <- liftIO $ inMVar $ cooc2graph 0 myCooc
   let graph' = set graph_metadata (Just metadata) graph
   pure graph'
 
@@ -146,3 +207,62 @@ postGraph = undefined
 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 putGraph = undefined
 
+------------------------------------------------------------
+
+type GraphAsyncAPI = Summary "Update graph"
+                   :> "async"
+                   :> AsyncJobsAPI ScraperStatus () ScraperStatus
+
+graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
+graphAsync u n =
+  serveJobsAPI $
+    JobFunction (\_ log' -> graphAsync' u n (liftIO . log'))
+
+
+graphAsync' :: UserId
+           -> NodeId
+           -> (ScraperStatus -> GargNoServer ())
+           -> GargNoServer ScraperStatus
+graphAsync' u n logStatus = do
+  logStatus ScraperStatus { _scst_succeeded = Just 0
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 1
+                          , _scst_events    = Just []
+                          }
+  _g <- trace (show u) $ recomputeGraph u n
+  pure  ScraperStatus { _scst_succeeded = Just 1
+                      , _scst_failed    = Just 0
+                      , _scst_remaining = Just 0
+                      , _scst_events    = Just []
+                      }
+
+------------------------------------------------------------
+
+type GraphVersionsAPI = Summary "Graph versions"
+                        :> Get '[JSON] GraphVersions
+                   :<|> Summary "Recompute graph version"
+                        :> Post '[JSON] Graph
+
+graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
+graphVersionsAPI u n =
+           graphVersions u n
+      :<|> recomputeVersions u n
+
+graphVersions :: UserId -> NodeId -> GargNoServer GraphVersions
+graphVersions _uId nId = do
+  nodeGraph <- getNodeWith nId HyperdataGraph
+  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+  let listVersion = graph ^? _Just
+                            . graph_metadata
+                            . _Just
+                            . gm_list
+                            . lfg_version
+
+  repo <- getRepo
+  let v = repo ^. r_version
+
+  pure $ GraphVersions { gv_graph = listVersion
+                       , gv_repo = v }
+
+recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
+recomputeVersions uId nId = recomputeGraph uId nId

src/Gargantext/Viz/Graph/Tools.hs

@@ -15,9 +15,9 @@ Portability : POSIX
 module Gargantext.Viz.Graph.Tools
   where
 
-import Debug.Trace (trace)
 import Data.Graph.Clustering.Louvain.Utils (LouvainNode(..))
-import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
+import Data.Graph.Clustering.Louvain (hLouvain, {-iLouvainMap-})
+-- import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
 import Data.Map (Map)
 import qualified Data.Set as Set
 import Data.Text (Text)
@@ -53,33 +53,33 @@ cooc2graph' threshold myCooc = distanceMap
 
 cooc2graph :: Threshold
            -> (Map (Text, Text) Int)
-           -> IO Graph
-cooc2graph threshold myCooc = do
-  let (ti, _) = createIndices myCooc
-      myCooc' = toIndex ti myCooc
-      matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
-      distanceMat = measureConditional matCooc
-      distanceMap = Map.filter (> threshold) $ mat2map distanceMat
+           -> Graph
+cooc2graph threshold myCooc = data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
+  where
+    (ti, _) = createIndices myCooc
+    myCooc' = toIndex ti myCooc
+    matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
+    distanceMat = measureConditional matCooc
+    distanceMap = Map.filter (> threshold) $ mat2map distanceMat
 
-  let nodesApprox :: Int
-      nodesApprox = n'
-        where
-          (as, bs) = List.unzip $ Map.keys distanceMap
-          n' = Set.size $ Set.fromList $ as <> bs
-      ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
+    nodesApprox :: Int
+    nodesApprox = n'
+      where
+        (as, bs) = List.unzip $ Map.keys distanceMap
+        n' = Set.size $ Set.fromList $ as <> bs
+    ClustersParams rivers _level = clustersParams nodesApprox
 
-  partitions <- inMVarIO $ case Map.size distanceMap > 0 of
-    True  -> trace ("level" <> show level) $ cLouvain level distanceMap
-    False -> panic "Text.Flow: DistanceMap is empty"
+    partitions = if (Map.size distanceMap > 0)
+        --then iLouvainMap 100 10 distanceMap
+        then hLouvain distanceMap
+        else panic "Text.Flow: DistanceMap is empty"
+        -- True  -> trace ("level" <> show level) $ cLouvain level distanceMap
 
-  bridgeness' <- trace "bridgeness" $ inMVar $ {-trace ("rivers: " <> show rivers) $-}
-                    bridgeness rivers partitions distanceMap
+    bridgeness' = bridgeness rivers partitions distanceMap
 
-  confluence' <- trace "confluence" $ inMVar $ confluence (Map.keys bridgeness') 3 True False
+    confluence' = confluence (Map.keys bridgeness') 3 True False
 
-  r <- trace "data2graph" $ inMVarIO $ data2graph (Map.toList ti) myCooc' bridgeness' confluence' partitions
 
-  pure r
 
 
 
@@ -106,12 +106,13 @@ data2graph :: [(Text, Int)]
            -> Map (Int, Int) Double
            -> Map (Int, Int) Double
            -> [LouvainNode]
-           -> IO Graph
-data2graph labels coocs bridge conf partitions = do
-    
-    let community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
+           -> Graph
+data2graph labels coocs bridge conf partitions = Graph nodes edges Nothing
+  where
 
-    nodes <- mapM (setCoord ForceAtlas labels bridge)
+    community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
+
+    nodes = map (setCoord ForceAtlas labels bridge)
           [ (n, Node { node_size = maybe 0 identity (Map.lookup (n,n) coocs)
                    , node_type = Terms -- or Unknown
                    , node_id    = cs (show n)
@@ -129,7 +130,7 @@ data2graph labels coocs bridge conf partitions = do
                            $ Map.toList bridge
             ]
 
-    let edges = [ Edge { edge_source = cs (show s)
+    edges = [ Edge { edge_source = cs (show s)
                        , edge_target = cs (show t)
                        , edge_weight =  d
                        , edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
@@ -138,7 +139,6 @@ data2graph labels coocs bridge conf partitions = do
                    | (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
                    ]
 
-    pure $ Graph nodes edges Nothing
 
 ------------------------------------------------------------------------
 
@@ -152,22 +152,23 @@ setCoord' f (i,n) = n { node_x_coord = x, node_y_coord = y }
 
 
 -- | ACP
-setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> IO Node
-setCoord l labels m (n,node) = getCoord l labels m n
-                           >>= \(x,y) -> pure $ node { node_x_coord = x
-                                                     , node_y_coord = y
-                                                     }
+setCoord :: Ord a => Layout -> [(a, Int)] -> Map (Int, Int) Double -> (Int, Node) -> Node
+setCoord l labels m (n,node) = node { node_x_coord = x
+                                    , node_y_coord = y
+                                    }
+  where
+    (x,y) = getCoord l labels m n
 
 
 getCoord :: Ord a => Layout
-                  -> [(a, Int)] -> Map (Int, Int) Double -> Int -> IO (Double, Double)
-getCoord KamadaKawai _ m n = layout m n
+                  -> [(a, Int)] -> Map (Int, Int) Double -> Int -> (Double, Double)
+getCoord KamadaKawai _ _m _n = undefined -- layout m n
 
-getCoord ForceAtlas _ _ n = pure (sin d, cos d)
+getCoord ForceAtlas _ _ n = (sin d, cos d)
   where
     d = fromIntegral n
 
-getCoord ACP labels m n = pure $ to2d $ maybe (panic "Graph.Tools no coordinate") identity
+getCoord ACP labels m n = to2d $ maybe (panic "Graph.Tools no coordinate") identity
              $ Map.lookup n
              $ pcaReduceTo (Dimension 2)
              $ mapArray labels m

src/Gargantext/Viz/Phylo/Aggregates.hs

@@ -27,7 +27,7 @@ import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
 
 import Debug.Trace (trace)
- 
+
 import Data.List    (partition, concat, nub, elem, sort, (++), null, union)
 import Data.Map     (Map, fromList, fromListWith, adjust, filterWithKey, elems, keys, unionWith, mapWithKey)
 import Data.Set     (size)

src/Gargantext/Viz/Phylo/PhyloTools.hs

@@ -492,4 +492,4 @@ traceTemporalMatching groups =
 
 traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
 traceGroupsProxi m = 
-    trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m
\ No newline at end of file
+    trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m

src/Gargantext/Viz/Phylo/TemporalMatching.hs

@@ -543,4 +543,4 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
                          (traceTemporalMatching $ getGroupsFromLevel 1 phylo)
     --------------------------------------
     thr :: Double
-    thr = toThreshold elevation (phylo ^. phylo_groupsProxi)
\ No newline at end of file
+    thr = toThreshold elevation (phylo ^. phylo_groupsProxi)

src/Gargantext/Viz/Phylo/View/ViewMaker.hs

@@ -170,4 +170,4 @@ traceView pv = trace ("------------\n--| View |--\n------------\n\n"
                              <> show (percentile 75 (VS.fromList lst)) <> " (75%) "
                              <> show (percentile 90 (VS.fromList lst)) <> " (90%)\n") pv
   where 
-    lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv
\ No newline at end of file
+    lst = sort $ map (fromIntegral . length . snd) $ getNodesByBranches pv

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
 - git: https://github.com/np/servant-job.git
   commit: 4016c76398a56e1a352a45b3ee9d698dd0dd2597
 - git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
-  commit: f8fd33e4e9639730d47cd02b223a0f8fbbbfe975
+  commit: 7d74f96dfea8e51fbab1793cc0429b2fe741f73d
 - git: https://github.com/np/patches-map
   commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
 - git: https://github.com/delanoe/haskell-opaleye.git  #- opaleye-0.6.7002.0