module Gargantext.Core.Viz.Graph.API
where
-import Control.Lens (set, (^.), _Just, (^?))
+import Control.Lens (set, (^.), _Just, (^?), at)
import Data.Aeson
-import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
import Data.Swagger
-import Data.Text
+import Data.Text hiding (head)
import Debug.Trace (trace)
import GHC.Generics (Generic)
-import Servant
-import Servant.Job.Async
-import Servant.XML
-
import Gargantext.API.Admin.Orchestrator.Types
-import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Prelude
+import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
+import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Main
+import Gargantext.Core.Viz.Graph
+import Gargantext.Core.Viz.Graph.GEXF ()
+import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd)
import Gargantext.Database.Query.Table.Node
-import Gargantext.Database.Query.Table.Node.User (getNodeUser)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.Node.User (getNodeUser)
+import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Schema.Node (node_parentId, node_hyperdata, node_name, node_userId)
import Gargantext.Prelude
-import Gargantext.Core.Viz.Graph
-import Gargantext.Core.Viz.Graph.GEXF ()
-import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
-import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..))
+import Servant
+import Servant.Job.Async
+import Servant.XML
+import qualified Data.HashMap.Strict as HashMap
------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted
getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
- let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
- let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
-
- repo <- getRepo
- let cId = maybe (panic "[G.V.G.API] Node has no parent")
+ let
+ graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ camera = nodeGraph ^. node_hyperdata . hyperdataCamera
+ cId = maybe (panic "[G.V.G.API] Node has no parent")
identity
- $ nodeGraph ^. node_parentId
+ $ nodeGraph ^. node_parent_id
+
+ listId <- defaultList cId
+ repo <- getRepo' [listId]
-- TODO Distance in Graph params
case graph of
Nothing -> do
- graph' <- computeGraph cId Conditional NgramsTerms repo
- mt <- defaultGraphMetadata cId "Title" repo
- let graph'' = set graph_metadata (Just mt) graph'
- let hg = HyperdataGraphAPI graph'' camera
+ let defaultMetric = Order1
+ graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
+ mt <- defaultGraphMetadata cId "Title" repo defaultMetric
+ let
+ graph'' = set graph_metadata (Just mt) graph'
+ hg = HyperdataGraphAPI graph'' camera
-- _ <- updateHyperdata nId hg
_ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
pure $ trace "[G.V.G.API] Graph empty, computing" hg
HyperdataGraphAPI graph' camera
-recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
-recomputeGraph _uId nId d = do
+recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
+recomputeGraph _uId nId maybeDistance = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
- let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
- let camera = nodeGraph ^. node_hyperdata . hyperdataCamera
- let graphMetadata = graph ^? _Just . graph_metadata . _Just
- let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
-
- repo <- getRepo
- let v = repo ^. r_version
- let cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
+ let
+ graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+ camera = nodeGraph ^. node_hyperdata . hyperdataCamera
+ graphMetadata = graph ^? _Just . graph_metadata . _Just
+ listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
+ graphMetric = case maybeDistance of
+ Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
+ _ -> maybeDistance
+
+ let
+ cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
identity
- $ nodeGraph ^. node_parentId
+ $ nodeGraph ^. node_parent_id
+ similarity = case graphMetric of
+ Nothing -> withMetric Order1
+ Just m -> withMetric m
+
+ listId <- defaultList cId
+ repo <- getRepo' [listId]
+ let v = repo ^. unNodeStory . at listId . _Just . a_version
case graph of
Nothing -> do
- graph' <- computeGraph cId d NgramsTerms repo
- mt <- defaultGraphMetadata cId "Title" repo
+ graph' <- computeGraph cId similarity NgramsTerms repo
+ mt <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
let graph'' = set graph_metadata (Just mt) graph'
_ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
Just graph' -> if listVersion == Just v
then pure graph'
else do
- graph'' <- computeGraph cId d NgramsTerms repo
+ graph'' <- computeGraph cId similarity NgramsTerms repo
let graph''' = set graph_metadata graphMetadata graph''
_ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
=> CorpusId
-> Distance
-> NgramsType
- -> NgramsRepo
+ -> NodeListStory
-> Cmd err Graph
computeGraph cId d nt repo = do
lId <- defaultList cId
-
lIds <- selectNodesWithUsername NodeList userMaster
- let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
- -- TODO split diagonal
- myCooc <- HM.filter (>1)
+ let ngs = filterListWithRoot MapTerm
+ $ mapTermListRoot [lId] nt repo
+
+ myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
- <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
+ <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
- graph <- liftBase $ cooc2graph d 0 myCooc
+ -- printDebug "myCooc" myCooc
+ -- saveAsFileDebug "debug/my-cooc" myCooc
+ graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
+ -- saveAsFileDebug "debug/graph" graph
pure graph
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
- -> NgramsRepo
+ -> NodeListStory
+ -> GraphMetric
-> Cmd err GraphMetadata
-defaultGraphMetadata cId t repo = do
+defaultGraphMetadata cId t repo gm = do
lId <- defaultList cId
pure $ GraphMetadata {
_gm_title = t
- , _gm_metric = Order1
+ , _gm_metric = gm
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
- , _gm_list = (ListForGraph lId (repo ^. r_version))
+ , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
, _scst_remaining = Just 1
, _scst_events = Just []
}
- _g <- trace (show u) $ recomputeGraph u n Conditional
+ _g <- trace (show u) $ recomputeGraph u n Nothing
pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
graphVersionsAPI u n =
- graphVersions n
+ graphVersions 0 n
:<|> recomputeVersions u n
-graphVersions :: NodeId -> GargNoServer GraphVersions
-graphVersions nId = do
+graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
+graphVersions n nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy 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 }
+ let
+ graph = nodeGraph
+ ^. node_hyperdata
+ . hyperdataGraph
+
+ listVersion = graph
+ ^? _Just
+ . graph_metadata
+ . _Just
+ . gm_list
+ . lfg_version
+
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
+ maybeListId <- defaultListMaybe cId
+ case maybeListId of
+ Nothing -> if n <= 2
+ then graphVersions (n+1) cId
+ else panic "[G.V.G.API] list not found after iterations"
+
+ Just listId -> do
+ repo <- getRepo' [listId]
+ let v = repo ^. unNodeStory . at listId . _Just . a_version
+ printDebug "graphVersions" v
+
+ pure $ GraphVersions { gv_graph = listVersion
+ , gv_repo = v }
recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
-recomputeVersions uId nId = recomputeGraph uId nId Conditional
+recomputeVersions uId nId = recomputeGraph uId nId Nothing
------------------------------------------------------------
graphClone :: UserId
let nodeType = NodeGraph
nodeUser <- getNodeUser (NodeId uId)
nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
- let uId' = nodeUser ^. node_userId
+ let uId' = nodeUser ^. node_user_id
nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
case nIds of
[] -> pure pId
getGraphGexf uId nId = do
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph
+
+
+
+
+
+