Merge branch '81-dev-zip-upload' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell...
[gargantext.git] / src / Gargantext / Core / Viz / Graph / API.hs
index 3e5ce282da5db3299f52065d028bfcc3d7cb6bde..3b608a365347b87a1fbe2e6212317c903aaf827e 100644 (file)
@@ -16,39 +16,39 @@ Portability : POSIX
 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
@@ -81,22 +81,26 @@ graphAPI u n = getGraph         u n
 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
@@ -105,24 +109,34 @@ getGraph _uId nId = do
         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''
@@ -130,7 +144,7 @@ recomputeGraph _uId nId d = do
     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'''
@@ -141,36 +155,40 @@ computeGraph :: HasNodeError err
              => 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"
@@ -178,7 +196,7 @@ defaultGraphMetadata cId t repo = 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])
@@ -206,7 +224,7 @@ graphRecompute u n logStatus = do
                    , _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
@@ -221,27 +239,43 @@ type GraphVersionsAPI = Summary "Graph versions"
 
 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 graphVersionsAPI u n =
-           graphVersions n
+           graphVersions 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
@@ -253,7 +287,7 @@ graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
   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
@@ -272,3 +306,9 @@ getGraphGexf :: UserId
 getGraphGexf uId nId = do
   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
   pure $ addHeader "attachment; filename=graph.gexf" graph
+
+
+
+
+
+