-}
-
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE TypeOperators #-}
module Gargantext.Core.Viz.Graph.API
where
-import Control.Lens (set, (^.), _Just, (^?))
+import Control.Lens (set, (^.), _Just, (^?), at)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Swagger
-import Data.Text
+import Data.Text hiding (head)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams.Tools
-import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
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.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Node
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 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
-- as simple Node.
:<|> graphVersionsAPI u n
------------------------------------------------------------------------
-getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
+--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
+getGraph :: FlowCmdM env err m
+ => UserId
+ -> NodeId
+ -> m HyperdataGraphAPI
getGraph _uId nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
- repo <- getRepo
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
+
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
+ printDebug "[getGraph] getting list for cId" cId
+ listId <- defaultList cId
+ repo <- getRepo' [listId]
-- TODO Distance in Graph params
case graph of
HyperdataGraphAPI graph' camera
-recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
+--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
+recomputeGraph :: FlowCmdM env err m
+ => UserId
+ -> NodeId
+ -> Maybe GraphMetric
+ -> m Graph
recomputeGraph _uId nId maybeDistance = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
let
graphMetric = case maybeDistance of
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
_ -> maybeDistance
-
- repo <- getRepo
- let
- v = repo ^. r_version
- cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
- identity
- $ nodeGraph ^. node_parentId
similarity = case graphMetric of
- Nothing -> withMetric Order2
+ Nothing -> withMetric Order1
Just m -> withMetric m
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
+ listId <- defaultList cId
+ repo <- getRepo' [listId]
+ let v = repo ^. unNodeStory . at listId . _Just . a_version
+
case graph of
Nothing -> do
graph' <- computeGraph cId similarity NgramsTerms repo
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
--- TODO use Database Monad only here ?
-computeGraph :: HasNodeError err
+computeGraph :: FlowCmdM env err m
=> CorpusId
-> Distance
-> NgramsType
- -> NgramsRepo
- -> Cmd err Graph
+ -> NodeListStory
+ -> m Graph
computeGraph cId d nt repo = do
lId <- defaultList cId
lIds <- selectNodesWithUsername NodeList userMaster
$ mapTermListRoot [lId] nt repo
myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
+ -- <$> HashMap.filterWithKey (\(x,y) _ -> x /= y)
+ -- <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
-- printDebug "myCooc" myCooc
+ -- saveAsFileDebug "debug/my-cooc" myCooc
+
+ listNgrams <- getListNgrams [lId] nt
+ -- graph <- liftBase $ cooc2graphWith Bac d 0 myCooc
graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
- pure graph
+ -- saveAsFileDebug "debug/graph" graph
+
+ pure $ mergeGraphNgrams graph (Just listNgrams)
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
- -> NgramsRepo
+ -> NodeListStory
-> GraphMetric
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo gm = do
, 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])
-
------------------------------------------------------------
type GraphAsyncAPI = Summary "Recompute graph"
:> "recompute"
JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
-graphRecompute :: UserId
+--graphRecompute :: UserId
+-- -> NodeId
+-- -> (JobLog -> GargNoServer ())
+-- -> GargNoServer JobLog
+graphRecompute :: FlowCmdM env err m
+ => UserId
-> NodeId
- -> (JobLog -> GargNoServer ())
- -> GargNoServer JobLog
+ -> (JobLog -> m ())
+ -> m JobLog
graphRecompute u n logStatus = do
logStatus JobLog { _scst_succeeded = Just 0
, _scst_failed = 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
. gm_list
. lfg_version
- repo <- getRepo
- let v = repo ^. r_version
+ mcId <- getClosestParentIdByType nId NodeCorpus
+ let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
- pure $ GraphVersions { gv_graph = listVersion
- , gv_repo = v }
+ 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"
-recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
+ 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 :: FlowCmdM env err m
+ => UserId
+ -> NodeId
+ -> m Graph
recomputeVersions uId nId = recomputeGraph uId nId Nothing
------------------------------------------------------------
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
pure nId
------------------------------------------------------------
-getGraphGexf :: UserId
+--getGraphGexf :: UserId
+-- -> NodeId
+-- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+getGraphGexf :: FlowCmdM env err m
+ => UserId
-> NodeId
- -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+ -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
getGraphGexf uId nId = do
HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
pure $ addHeader "attachment; filename=graph.gexf" graph
+