Merge branch 'dev' into dev-api-node-count

src/Gargantext/API.hs

@@ -351,7 +351,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
      :<|> withAccess  (Proxy :: Proxy TableNgramsApi) Proxy uid <$> PathNode <*> apiNgramsTableDoc
      :<|> count -- TODO: undefined
      :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid <$> PathNode <*> searchPairs -- TODO: move elsewhere
-     :<|> withAccess (Proxy :: Proxy GraphAPI)       Proxy uid <$> PathNode <*> graphAPI -- TODO: mock
+     :<|> withAccess (Proxy :: Proxy GraphAPI)       Proxy uid <$> PathNode <*> graphAPI uid -- TODO: mock
      :<|> withAccess (Proxy :: Proxy TreeAPI)        Proxy uid <$> PathNode <*> treeAPI
      :<|> addToCorpus
      :<|> New.api -- TODO-SECURITY

src/Gargantext/API/Ngrams.hs

@@ -83,6 +83,10 @@ module Gargantext.API.Ngrams
   , getNgramsTableMap
   , tableNgramsPull
   , tableNgramsPut
+
+  , Versioned(..)
+  , currentVersion
+  , listNgramsChangedSince
   )
   where
 
@@ -1053,7 +1057,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
                           % " map1=" % timeSpecs
                           % " map2=" % timeSpecs
                           % " map3=" % timeSpecs
-                          % " sql="  % if nSco then "map2" else "map3"
+                          % " sql="  % (if nSco then "map2" else "map3")
                           % "\n"
             ) t0 t3 t0 t1 t1 t2 t2 t3
   pure tableMap3

src/Gargantext/API/Node.hs

@@ -143,7 +143,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "pie"       :> PieApi
              :<|> "tree"      :> TreeApi
              :<|> "phylo"     :> PhyloAPI
-             :<|> "upload"    :> UploadAPI
+             :<|> "add"       :> NodeAddAPI
 
 -- TODO-ACCESS: check userId CanRenameNode nodeId
 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
@@ -201,7 +201,8 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
            :<|> getPie     id
            :<|> getTree    id
            :<|> phyloAPI   id uId
-           :<|> postUpload id
+           :<|> nodeAddAPI id
+           -- :<|> postUpload id
 
     deleteNodeApi id' = do
       node <- getNode' id'
@@ -377,6 +378,12 @@ instance (ToParamSchema a, HasSwagger sub) =>
         & in_         .~ ParamFormData
         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 
+type NodeAddAPI = "file" :> Summary "Node add API"
+                         :> UploadAPI
+
+nodeAddAPI :: NodeId -> GargServer NodeAddAPI
+nodeAddAPI id =  postUpload       id
+
 type UploadAPI = Summary "Upload file(s) to a corpus"
                 :> MultipartForm Mem (MultipartData Mem)
                 :> QueryParam "fileType"  FileType

src/Gargantext/Database/Node/UpdateOpaleye.hs

+{-|
+Module      : Gargantext.Database.Node.UpdateOpaleye
+Description : Update Node in Database (Postgres)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RankNTypes        #-}
+
+
+module Gargantext.Database.Node.UpdateOpaleye where
+
+
+import Opaleye
+import Data.Aeson (encode, ToJSON)
+import Gargantext.Prelude
+import Gargantext.Database.Schema.Node 
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Utils (Cmd, mkCmd)
+
+updateHyperdata :: ToJSON a => NodeId -> a -> Cmd err Int64
+updateHyperdata i h = mkCmd $ \c -> runUpdate_ c (updateHyperdataQuery i h)
+
+updateHyperdataQuery :: ToJSON a => NodeId -> a -> Update Int64
+updateHyperdataQuery i h = Update
+   { uTable      = nodeTable
+   , uUpdateWith = updateEasy (\  (Node _ni _nt _nu _np _nn _nd _h)
+                                -> Node _ni _nt _nu _np _nn _nd h'
+                              )
+   , uWhere      = (\row -> _node_id row .== pgNodeId i )
+   , uReturning  = rCount
+   }
+    where h' =  (pgJSONB $ cs $ encode $ h)
+

src/Gargantext/Database/Schema/Node.hs

@@ -44,6 +44,7 @@ import Gargantext.Database.Queries.Filter (limit', offset')
 import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
 import Gargantext.Database.Utils
 import Gargantext.Prelude hiding (sum, head)
+import Gargantext.Viz.Graph (HyperdataGraph(..))
 
 import Opaleye hiding (FromField)
 import Opaleye.Internal.QueryArr (Query)
@@ -218,11 +219,11 @@ nodeTable :: Table NodeWrite NodeRead
 nodeTable = Table "nodes" (pNode Node { _node_id         = optional "id"
                                       , _node_typename   = required "typename"
                                       , _node_userId     = required "user_id"
-                                      
+
                                       , _node_parentId   = optional "parent_id"
                                       , _node_name       = required "name"
                                       , _node_date       = optional "date"
-                                      
+
                                       , _node_hyperdata  = required "hyperdata"
                                       }
                             )
@@ -266,21 +267,19 @@ type NodeSearchReadNull =
     (Column (Nullable PGJsonb)      )
     (Column (Nullable PGTSVector)   )
 
---{-
 nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
 nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id         = optional "id"
                                       , _ns_typename   = required "typename"
                                       , _ns_userId     = required "user_id"
-                                      
+
                                       , _ns_parentId   = required "parent_id"
                                       , _ns_name       = required "name"
                                       , _ns_date       = optional "date"
-                                      
+
                                       , _ns_hyperdata  = required "hyperdata"
                                       , _ns_search     = optional "search"
                                       }
                             )
---}
 
 queryNodeSearchTable :: Query NodeSearchRead
 queryNodeSearchTable = queryTable nodeTableSearch
@@ -434,7 +433,6 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
     name     = maybe "Annuaire" identity maybeName
     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 
-
 ------------------------------------------------------------------------
 
 {-
@@ -498,7 +496,7 @@ nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just
 
 ------------------------------------------------------------------------
 arbitraryGraph :: HyperdataGraph
-arbitraryGraph = HyperdataGraph (Just "Preferences")
+arbitraryGraph = HyperdataGraph Nothing
 
 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
 nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
@@ -506,6 +504,12 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
     name = maybe "Graph" identity maybeName
     graph = maybe arbitraryGraph identity maybeGraph
 
+mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
+mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
+
+insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
+insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
+
 ------------------------------------------------------------------------
 arbitraryPhylo :: HyperdataPhylo
 arbitraryPhylo = HyperdataPhylo Nothing Nothing
@@ -518,10 +522,8 @@ nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
 
 
 ------------------------------------------------------------------------
-
 arbitraryDashboard :: HyperdataDashboard
 arbitraryDashboard = HyperdataDashboard (Just "Preferences")
-
 ------------------------------------------------------------------------
 
 node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
@@ -695,11 +697,6 @@ defaultList cId =
 mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
 mkNode nt p u = insertNodesR [nodeDefault nt p u]
 
-
-mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
-mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-
-
 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
   where

src/Gargantext/Database/Types/Node.hs

@@ -62,13 +62,13 @@ import           Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import           Gargantext.Viz.Phylo (Phylo)
 --import Gargantext.Database.Utils
 ------------------------------------------------------------------------
+
 newtype NodeId = NodeId Int
   deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
 
 instance ToField NodeId where
   toField (NodeId n) = toField n
 
-
 instance FromField NodeId where
   fromField field mdata = do
     n <- fromField field mdata
@@ -78,6 +78,7 @@ instance FromField NodeId where
 
 instance ToSchema NodeId
 
+
 type NodeTypeId   = Int
 type NodeName     = Text
 type TSVector     = Text
@@ -87,13 +88,13 @@ data NodePoly id        typename userId
               parentId  name     date 
               hyperdata  = Node { _node_id        :: id
                                 , _node_typename  :: typename
-                                
+
                                 , _node_userId    :: userId
                                 , _node_parentId  :: parentId
-                                
+
                                 , _node_name      :: name
                                 , _node_date      :: date
-                                
+
                                 , _node_hyperdata :: hyperdata
                                 } deriving (Show, Generic)
 $(deriveJSON (unPrefix "_node_") ''NodePoly)
@@ -103,7 +104,6 @@ $(makeLenses ''NodePoly)
 type Node json   = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
 
 
-
 ------------------------------------------------------------------------
 
 
@@ -401,13 +401,6 @@ $(deriveJSON (unPrefix "hyperdataDashboard_") ''HyperdataDashboard)
 
 instance Hyperdata HyperdataDashboard
 
--- TODO add the Graph Structure here
-data HyperdataGraph = HyperdataGraph { hyperdataGraph_preferences   :: !(Maybe Text)
-                                   } deriving (Show, Generic)
-$(deriveJSON (unPrefix "hyperdataGraph_") ''HyperdataGraph)
-
-instance Hyperdata HyperdataGraph
-
 ------------------------------------------------------------------------
 
 -- TODO add the Graph Structure here

src/Gargantext/Database/Utils.hs

@@ -73,12 +73,13 @@ mkCmd k = do
   conn <- view connection
   liftIO $ k conn
 
-runCmd :: (HasConnection env) => env
-       -> Cmd' env err a
+runCmd :: (HasConnection env)
+       => env -> Cmd' env err a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env
 
-runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
+runOpaQuery :: Default FromFields fields haskells
+            => Select fields -> Cmd err [haskells]
 runOpaQuery q = mkCmd $ \c -> runQuery c q
 
 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString

src/Gargantext/Viz/Graph.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE DeriveGeneric     #-}
@@ -26,7 +27,7 @@ import GHC.Generics (Generic)
 import GHC.IO (FilePath)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Core.Types (ListId)
-import Gargantext.Database.Types.Node (NodeId)
+import Gargantext.Database.Types.Node (NodeId, Hyperdata)
 import Gargantext.Prelude
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -87,6 +88,7 @@ data GraphMetadata = GraphMetadata { _gm_title    :: Text   -- title of the grap
                                    , _gm_corpusId :: [NodeId]  -- we can map with different corpus
                                    , _gm_legend :: [LegendField] -- legend of the Graph
                                    , _gm_listId :: ListId
+                                   , _gm_version :: Int
                                    }
   deriving (Show, Generic)
 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
@@ -143,6 +145,15 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 $(deriveJSON (unPrefix "go_") ''GraphV3)
 
 -----------------------------------------------------------
+
+data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
+                                   } deriving (Show, Generic)
+$(deriveJSON (unPrefix "") ''HyperdataGraph)
+
+instance Hyperdata HyperdataGraph
+makeLenses ''HyperdataGraph
+
+
 -----------------------------------------------------------
 
 graphV3ToGraph :: GraphV3 -> Graph

src/Gargantext/Viz/Graph/API.hs

@@ -24,8 +24,10 @@ Portability : POSIX
 module Gargantext.Viz.Graph.API
   where
 
-import Control.Lens (set)
+import Control.Lens (set, (^.), _Just, (^?))
 import Control.Monad.IO.Class (liftIO)
+import Data.Maybe (Maybe(..))
+import Gargantext.API.Ngrams (currentVersion)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Types
 import Gargantext.Core.Types.Main
@@ -33,9 +35,9 @@ import Gargantext.Database.Config
 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Database.Node.Select
-import Gargantext.Database.Schema.Node (getNode)
-import Gargantext.Database.Schema.Node (defaultList)
+import Gargantext.Database.Schema.Node (getNode, defaultList, insertGraph)
 import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
+import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Prelude
 import Gargantext.Viz.Graph
 import Gargantext.Viz.Graph.Tools -- (cooc2graph)
@@ -51,38 +53,68 @@ type GraphAPI   =  Get  '[JSON] Graph
               :<|> Put  '[JSON] Int
 
 
-graphAPI :: NodeId -> GargServer GraphAPI
-graphAPI n =  getGraph  n
+graphAPI :: UserId -> NodeId -> GargServer GraphAPI
+graphAPI u n =  getGraph  u n
          :<|> postGraph n
          :<|> putGraph  n
 
 ------------------------------------------------------------------------
 
-getGraph :: NodeId -> GargServer (Get '[JSON] Graph)
-getGraph nId = do
+getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
+getGraph uId nId = do
   nodeGraph <- getNode nId HyperdataGraph
-  -- get HyperdataGraphp from Database
-  -- if Nothing else if version == current version then compute
-
-  let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
+  let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
+  let graphVersion = graph ^? _Just
+                            . graph_metadata
+                            . _Just
+                            . gm_version
+
+  v <- currentVersion
+  nodeUser <- getNode (NodeId uId) HyperdataUser
+
+  let uId' = nodeUser ^. node_userId
+
+  let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
+                  identity
+                  $ nodeGraph ^. node_parentId
+  case graph of
+    Nothing     -> do
+      graph' <- computeGraph cId NgramsTerms v
+      _ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
+      pure graph'
+
+    Just graph' -> if graphVersion == Just v
+                     then pure graph'
+                     else do
+                       graph'' <- computeGraph cId NgramsTerms v
+                       _ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
+                       pure graph''
+
+-- TODO use Database Monad only here ?
+computeGraph :: CorpusId -> NgramsType -> Int -> GargServer (Get '[JSON] Graph)
+computeGraph cId nt v = do
   lId  <- defaultList cId
 
-  let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
+  let metadata = GraphMetadata "Title" [cId]
                                      [ LegendField 1 "#FFF" "Cluster"
                                      , LegendField 2 "#FFF" "Cluster"
                                      ]
                                 lId
+                                v
                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 
   lIds <- selectNodesWithUsername NodeList userMaster
-  ngs  <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
+  ngs  <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] nt
 
-  myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
-                            <$> groupNodesByNgrams ngs
-                            <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) NgramsTerms (Map.keys ngs)
+  myCooc <- Map.filter (>1)
+         <$> getCoocByNgrams (Diagonal True)
+         <$> groupNodesByNgrams ngs
+         <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
 
   graph <- liftIO $ cooc2graph 0 myCooc
-  pure $ set graph_metadata (Just metadata) graph
+  let graph' = set graph_metadata (Just metadata) graph
+  pure graph'
+
 
 
 postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
@@ -91,8 +123,3 @@ postGraph = undefined
 putGraph :: NodeId -> GargServer (Put '[JSON] Int)
 putGraph = undefined
 
-
-
-
--- | Instances
-

src/Gargantext/Viz/Graph/Tools.hs

@@ -15,10 +15,10 @@ Portability : POSIX
 module Gargantext.Viz.Graph.Tools
   where
 
---import Debug.Trace (trace)
 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
 import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
 import Data.Map (Map)
+import qualified Data.Set as Set
 import Data.Text (Text)
 import Gargantext.Prelude
 import Gargantext.Core.Statistics
@@ -35,15 +35,17 @@ import qualified Data.Vector.Storable as Vec
 import qualified Data.Map  as Map
 import qualified Data.List as List
 
-type Threshold = Int
+type Threshold = Double
 
-cooc2graph :: Threshold -> (Map (Text, Text) Int) -> IO Graph
+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 (>threshold) myCooc'
+      matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
       distanceMat = measureConditional matCooc
-      distanceMap = Map.filter (>0.01) $ mat2map distanceMat
+      distanceMap = Map.filter (> threshold) $ mat2map distanceMat
 
   partitions <- case Map.size distanceMap > 0 of
     True  -> cLouvain distanceMap
@@ -57,11 +59,12 @@ cooc2graph threshold myCooc = do
 
 ----------------------------------------------------------
 -- | From data to Graph
-data2graph :: [(Text, Int)] -> Map (Int, Int) Int
-                            -> Map (Int, Int) Double
-                            -> Map (Int, Int) Double
-                            -> [LouvainNode]
-              -> IO Graph
+data2graph :: [(Text, Int)]
+           -> Map (Int, Int) 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 ]
@@ -74,18 +77,24 @@ data2graph labels coocs bridge conf partitions = do
                    , node_x_coord = 0
                    , node_y_coord = 0
                    , node_attributes =
-                     Attributes { clust_default = maybe 0 identity 
+                     Attributes { clust_default = maybe 0 identity
                                 (Map.lookup n community_id_by_node_id) } }
                )
             | (l, n) <- labels
+            , Set.member n $ Set.fromList
+                           $ List.concat
+                           $ map (\((s,t),d) -> if d > 0 && s /=t then [s,t] else [])
+                           $ Map.toList bridge
             ]
 
     let edges = [ Edge { edge_source = cs (show s)
-                   , edge_target = cs (show t)
-                   , edge_weight = d
-                   , edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
+                       , edge_target = cs (show t)
+                       , edge_weight =  d
+                       , edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
+                   -- , edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
                    , edge_id     = cs (show i) }
-            | (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge) ]
+                   | (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
+                   ]
 
     pure $ Graph nodes edges Nothing