Skip to content

H
haskell-gargantext
Commit 005d8dcc authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge branch 'dev-graph-async' into dev

parents 782dee8b 0877ea16
Hide whitespace changes
Inline Side-by-side
Showing with 177 additions and 61 deletions
src/Gargantext/API/Corpus/New.hs
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -323,5 +323,3 @@ inMVar f = do
_ <- liftIO $ forkIO $ putMVar mVar zVar
liftIO $ takeMVar mVar
src/Gargantext/Viz/Graph/API.hs
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
View file @ 005d8dcc
......@@ -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
......
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