Merge branch 'dev-ngrams-repo' of...

Merge branch 'dev-ngrams-repo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext into dev-ngrams-repo

package.yaml

@@ -50,6 +50,7 @@ library:
   - Gargantext.Text.Examples
   - Gargantext.Text.List.CSV
   - Gargantext.Text.Metrics
+  - Gargantext.Text.Metrics.TFICF
   - Gargantext.Text.Metrics.CharByChar
   - Gargantext.Text.Metrics.Count
   - Gargantext.Text.Parsers

src/Gargantext/API.hs

@@ -248,10 +248,12 @@ type GargAPI' =
                         :> QueryParam "limit"  Int
                         :> QueryParam "order"  OrderBy
                         :> SearchAPI
-           
+
+           -- TODO move to NodeAPI?
            :<|> "graph" :> Summary "Graph endpoint"
                         :> Capture "id" NodeId       :> GraphAPI
-           
+
+           -- TODO move to NodeAPI?
            -- Tree endpoint
            :<|> "tree" :> Summary "Tree endpoint"
                        :> Capture "id" NodeId        :> TreeAPI
@@ -285,15 +287,17 @@ serverGargAPI :: GargServer GargAPI
 serverGargAPI -- orchestrator
        =  auth
      :<|> roots
-     :<|> nodeAPI  (Proxy :: Proxy HyperdataAny)
-     :<|> nodeAPI  (Proxy :: Proxy HyperdataCorpus)
-     :<|> nodeAPI  (Proxy :: Proxy HyperdataAnnuaire)
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataAny)      fakeUserId
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataCorpus)   fakeUserId
+     :<|> nodeAPI  (Proxy :: Proxy HyperdataAnnuaire) fakeUserId
      :<|> nodesAPI
      :<|> count -- TODO: undefined
      :<|> search
      :<|> graphAPI -- TODO: mock
      :<|> treeAPI
   --   :<|> orchestrator
+  where
+    fakeUserId = 1 -- TODO
 
 serverIndex :: Server (Get '[HTML] Html)
 serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))

src/Gargantext/API/Count.hs

@@ -44,6 +44,8 @@ import Gargantext.Prelude
 import Gargantext.Core.Utils.Prefix (unPrefix)
 
 -----------------------------------------------------------------------
+-- TODO-ACCESS: CanCount
+-- TODO-EVENTS: No events as this is a read only query.
 type CountAPI = Post '[JSON] Counts
 
 -----------------------------------------------------------------------

src/Gargantext/API/Node.hs

@@ -50,7 +50,7 @@ import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, ta
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Utils -- (Cmd, CmdM)
-import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
+import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
 import Gargantext.Database.Node.Children (getChildren)
 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
@@ -76,7 +76,11 @@ type GargServer api = forall env m. (CmdM env ServantErr m, HasRepoVar env)
                                  => ServerT api m
 
 -------------------------------------------------------------------
--- | TODO : access by admin only
+-- TODO-ACCESS: access by admin only.
+--              At first let's just have an isAdmin check.
+--              Later: check userId CanDeleteNodes Nothing
+-- TODO-EVENTS: DeletedNodes [NodeId]
+--              {"tag": "DeletedNodes", "nodes": [Int*]}
 type NodesAPI  = Delete '[JSON] Int
 
 -- | Delete Nodes
@@ -86,8 +90,13 @@ nodesAPI :: [NodeId] -> GargServer NodesAPI
 nodesAPI ids = deleteNodes ids
 
 ------------------------------------------------------------------------
--- | TODO: access by admin only
--- To manager the Users roots
+-- | TODO-ACCESS: access by admin only.
+-- At first let's just have an isAdmin check.
+-- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
+-- To manage the Users roots
+-- TODO-EVENTS:
+--   PutNode ?
+-- TODO needs design discussion.
 type Roots =  Get    '[JSON] [NodeAny]
          :<|> Put    '[JSON] Int -- TODO
 
@@ -98,10 +107,21 @@ roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 
 -------------------------------------------------------------------
 -- | Node API Types management
--- TODO : access by users
+-- TODO-ACCESS : access by users
+-- No ownership check is needed if we strictly follow the capability model.
+--
+-- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
+--             SearchAPI)
+-- CanRenameNode (or part of CanEditNode?)
+-- CanCreateChildren (PostNodeApi)
+-- CanEditNode / CanPutNode TODO not implemented yet
+-- CanDeleteNode
+-- CanPatch (TableNgramsApi)
+-- CanFavorite
+-- CanMoveToTrash
 type NodeAPI a = Get '[JSON] (Node a)
              :<|> "rename" :> RenameApi
-             :<|> PostNodeApi
+             :<|> PostNodeApi -- TODO move to children POST
              :<|> Put    '[JSON] Int
              :<|> Delete '[JSON] Int
              :<|> "children"  :> ChildrenApi a
@@ -122,6 +142,8 @@ type NodeAPI a = Get '[JSON] (Node a)
                         :> QueryParam "order"  OrderBy
                         :> SearchAPI
 
+-- TODO-ACCESS: check userId CanRenameNode nodeId
+-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 type RenameApi = Summary " Rename Node"
                :> ReqBody '[JSON] RenameNode
                :> Put     '[JSON] [Int]
@@ -137,10 +159,11 @@ type ChildrenApi a = Summary " Summary children"
                  :> Get '[JSON] [Node a]
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
-nodeAPI p id =  getNode     id p
+nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p uId id
+             =  getNode     id p
            :<|> rename      id
-           :<|> postNode    id
+           :<|> postNode    uId id
            :<|> putNode     id
            :<|> deleteNode  id
            :<|> getChildren id p
@@ -248,6 +271,8 @@ type ChartApi = Summary " Chart API"
              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 
 ------------------------------------------------------------------------
+-- TODO-ACCESS: CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
 type GraphAPI   = Get '[JSON] Graph
 
 graphAPI :: NodeId -> GargServer GraphAPI
@@ -255,12 +280,10 @@ graphAPI nId = do
 
   nodeGraph <- getNode nId HyperdataGraph
 
-  let title = "IMT - Scientific publications - 1982-2017 - English"
+  let title = "Title"
   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
-                                     [ LegendField 6 "#FFF" "Data processing"
-                                     , LegendField 7 "#FFF" "Networks"
-                                     , LegendField 1 "#FFF" "Material science"
-                                     , LegendField 5 "#FFF" "Energy / Environment"
+                                     [ LegendField 1 "#FFF" "Cluster"
+                                     , LegendField 2 "#FFF" "Cluster"
                                      ]
                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
@@ -302,6 +325,8 @@ instance HasTreeError ServantErr where
       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 
 type TreeAPI   = Get '[JSON] (Tree NodeTree)
+-- TODO-ACCESS: CanTree or CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
 treeAPI :: NodeId -> GargServer TreeAPI
 treeAPI = treeDB
 
@@ -331,8 +356,8 @@ getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
                    -> Cmd err [FacetChart]
 getChart _ _ _ = undefined -- TODO
 
-postNode :: NodeId -> PostNode -> Cmd err [NodeId]
-postNode pId (PostNode name nt) = mk nt (Just pId) name
+postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
+postNode uId pId (PostNode name nt) = mkNodeWithParent nt (Just pId) uId name
 
 putNode :: NodeId -> Cmd err Int
 putNode = undefined -- TODO

src/Gargantext/API/Search.hs

@@ -85,6 +85,8 @@ instance ToSchema SearchResults where
       defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
 
 -----------------------------------------------------------------------
+-- TODO-ACCESS: CanSearch? or is it part of CanGetNode
+-- TODO-EVENTS: No event, this is a read-only query.
 type SearchAPI = Post '[JSON] SearchResults
 -----------------------------------------------------------------------
 

src/Gargantext/Database/Flow.hs

@@ -97,7 +97,13 @@ flowInsertAnnuaire name children = do
 
   pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
 
-
+-- TODO-ACCESS:
+--   check userId       CanFillUserCorpus   userCorpusId
+--   check masterUserId CanFillMasterCorpus masterCorpusId
+--
+-- TODO-EVENTS:
+--   InsertedNgrams ?
+--   InsertedNodeNgrams ?
 flowCorpus' :: HasNodeError err
             => NodeType -> [HyperdataDocument]
             -> ([ReturnId], UserId, CorpusId, UserId, CorpusId)

src/Gargantext/Database/Metrics/TFICF.hs

@@ -143,4 +143,3 @@ GROUP BY nu.id,nu.terms
   |]
 
 
-

src/Gargantext/Database/Node/Document/Insert.hs

@@ -113,6 +113,8 @@ import Database.PostgreSQL.Simple (formatQuery)
 
 data ToDbData = ToDbDocument HyperdataDocument | ToDbContact HyperdataContact
 
+-- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
+-- TODO-EVENTS: InsertedNodes
 insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd err [ReturnId]
 insertDocuments uId pId nodeType =
     runPGSQuery queryInsert . Only . Values fields . prepare uId pId nodeType

src/Gargantext/Database/Schema/Ngrams.hs

@@ -58,13 +58,11 @@ type NgramsTerms = Text
 type NgramsId    = Int
 type Size        = Int
 
---{-
 data NgramsPoly id terms n = NgramsDb { ngrams_id    :: id
-                                    , ngrams_terms :: terms
-                                    , ngrams_n     :: n
-                                    } deriving (Show)
+                                      , ngrams_terms :: terms
+                                      , ngrams_n     :: n
+                                      } deriving (Show)
 
---}
 type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
                                    (Column PGText)
                                    (Column PGInt4)
@@ -77,7 +75,6 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
                                  (Column (Nullable PGText))
                                  (Column (Nullable PGInt4))
 
---{-
 type NgramsDb = NgramsPoly Int Text Int
 
 $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
@@ -85,17 +82,16 @@ $(makeAdaptorAndInstance "pNgramsDb"    ''NgramsPoly)
 
 ngramsTable :: Table NgramsWrite NgramsRead
 ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id    = optional "id"
-                                            , ngrams_terms = required "terms"
-                                            , ngrams_n     = required "n"
-                                            }
-                                )
---{-
+                                                 , ngrams_terms = required "terms"
+                                                 , ngrams_n     = required "n"
+                                                 }
+                              )
+
 queryNgramsTable :: Query NgramsRead
 queryNgramsTable = queryTable ngramsTable
 
 dbGetNgramsDb :: Cmd err [NgramsDb]
 dbGetNgramsDb = runOpaQuery queryNgramsTable
---}
 
 -- | Main Ngrams Types
 -- | Typed Ngrams
@@ -193,9 +189,11 @@ indexNgramsTWith = fmap . indexNgramsWith
 indexNgramsWith :: (NgramsTerms -> NgramsId) -> Ngrams -> NgramsIndexed
 indexNgramsWith f n = NgramsIndexed n (f $ _ngramsTerms n)
 
+-- TODO-ACCESS: access must not be checked here but when insertNgrams is called.
 insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
 insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
 
+-- TODO-ACCESS: access must not be checked here but when insertNgrams' is called.
 insertNgrams' :: [Ngrams] -> Cmd err [NgramIds]
 insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
   where

src/Gargantext/Database/Schema/Node.hs

@@ -500,29 +500,20 @@ childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Nod
 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 
 
--- | TODO Use right userId
-mk :: NodeType -> Maybe ParentId -> Text -> Cmd err [NodeId]
-mk nt pId name  = mk' nt userId pId name
-  where
-    userId = 1
+type Name = Text
 
-mk' :: NodeType -> UserId -> Maybe ParentId -> Text -> Cmd err [NodeId]
-mk' nt uId pId name  = insertNodesWithParentR pId [node nt name hd pId uId]
+mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
+mkNodeWithParent NodeUser (Just _) _   _     = nodeError UserNoParent
+mkNodeWithParent _        Nothing  _   _     = nodeError HasParent
+mkNodeWithParent nt       pId     uId name   =
+    insertNodesWithParentR pId [node nt name hd pId uId]
   where
     hd = HyperdataUser . Just . pack $ show EN
 
-type Name = Text
-
-mk'' :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
-mk'' NodeUser Nothing uId name  = mk' NodeUser uId Nothing name
-mk'' NodeUser _       _   _     = nodeError UserNoParent
-mk'' _        Nothing _   _     = nodeError HasParent
-mk'' nt       pId     uId name  = mk' nt uId pId name
-
 mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
 mkRoot uname uId = case uId > 0 of
                False -> nodeError NegativeId
-               True  -> mk'' NodeUser Nothing uId uname
+               True  -> mkNodeWithParent NodeUser Nothing uId uname
 
 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [CorpusId]
 mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]

src/Gargantext/Database/Schema/NodeNgram.hs

@@ -288,6 +288,8 @@ data NodeNgramsUpdate = NodeNgramsUpdate
   }
 
 -- TODO wrap these updates in a transaction.
+-- TODO-ACCESS:
+-- * check userId CanUpdateNgrams userListId
 updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
 updateNodeNgrams nnu = do
   updateNodeNgrams' userListId $ _nnu_lists_update nnu

src/Gargantext/Prelude.hs

@@ -26,12 +26,14 @@ module Gargantext.Prelude
   , module Text.Read
   , cs
   , module Data.Maybe
+  , round
   , sortWith
   )
   where
 
 import GHC.Exts (sortWith)
 import GHC.Err.Located (undefined)
+import GHC.Real (round)
 import Control.Monad.IO.Class (MonadIO)
 import Data.Maybe (isJust, fromJust, maybe)
 import Protolude ( Bool(True, False), Int, Int64, Double, Integer

src/Gargantext/Text/Flow.hs

@@ -18,40 +18,33 @@ From text to viz, all the flow of texts in Gargantext.
 module Gargantext.Text.Flow
   where
 
+--import qualified Data.Array.Accelerate as A
+--import qualified Data.Set as DS
 import Control.Monad.Reader
-import GHC.IO (FilePath)
-import qualified Data.Text as T
-import Data.Text.IO (readFile)
-
+import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
 import Data.Map.Strict (Map)
 import Data.Maybe (catMaybes)
---import qualified Data.Set as DS
-import Data.Text (Text)
-
---import qualified Data.Array.Accelerate as A
 import qualified Data.Map.Strict as M
-----------------------------------------------
+import qualified Data.Text as T
+import Data.Text (Text)
+import Data.Text.IO (readFile)
 import Database.PostgreSQL.Simple (Connection)
-
+import GHC.IO (FilePath)
+import Gargantext.Core (Lang)
+import Gargantext.Core.Types (CorpusId)
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Types.Node
-
-import Gargantext.Core (Lang)
 import Gargantext.Prelude
-
-import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map)
-import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
-import Gargantext.Viz.Graph (Graph(..), data2graph)
-import Gargantext.Text.Metrics.Count (cooc)
-import Gargantext.Text.Metrics (filterCooc, FilterConfig(..), Clusters(..), SampleBins(..), DefaultValue(..), MapListSize(..), InclusionSize(..))
-import Gargantext.Text.Terms (TermType, extractTerms)
 import Gargantext.Text.Context (splitBy, SplitContext(Sentences))
-import Gargantext.Core.Types (CorpusId)
-
+import Gargantext.Text.Metrics (filterCooc, FilterConfig(..), Clusters(..), SampleBins(..), DefaultValue(..), MapListSize(..), InclusionSize(..))
+import Gargantext.Text.Metrics.Count (cooc)
 import Gargantext.Text.Parsers.CSV
-
-import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
-
+import Gargantext.Text.Terms (TermType, extractTerms)
+import Gargantext.Viz.Graph (Graph(..), data2graph)
+import Gargantext.Viz.Graph.Bridgeness (bridgeness)
+import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
+--import Gargantext.Viz.Graph.Distances.Matrice (distributional)
+import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map)
 {-
   ____                             _            _
  / ___| __ _ _ __ __ _  __ _ _ __ | |_ _____  _| |_
@@ -161,12 +154,13 @@ cooc2graph myCooc = do
 
 --  let distance = fromIndex fi distanceMap
   --printDebug "distance" $ M.size distance
-  
+
   partitions <- case M.size distanceMap > 0 of
                   True  -> cLouvain distanceMap
                   False -> panic "Text.Flow: DistanceMap is empty"
 -- Building : -> Graph -> JSON
   --printDebug "partitions" $ DS.size $ DS.fromList $ map (l_community_id) partitions
   --printDebug "partitions" partitions
-  pure $ data2graph (M.toList ti) myCooc4 distanceMap partitions
+  let distanceMap' = bridgeness 300 partitions distanceMap
+  pure $ data2graph (M.toList ti) myCooc4 distanceMap' partitions
 

src/Gargantext/Text/Metrics.hs

@@ -63,7 +63,7 @@ filterCooc' (FilterConfig _ _ _ _ (DefaultValue dv)) ts m = trace ("coocScored "
   where
     selection  = [(x,y) | x <- ts
                         , y <- ts
-                      --  , x >= y
+                        , x > y
                         ]
 
 

src/Gargantext/Viz/Graph/Bridgeness.hs

+{-|
+Module      : Gargantext.Viz.Graph.Bridgeness
+Description : Bridgeness filter
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Let be a graph with partitions (from Louvain algo), Bridgeness uniformly
+filters inter-communities links.
+
+-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Gargantext.Viz.Graph.Bridgeness (bridgeness)
+  where
+--import GHC.Base (Semigroup)
+import Gargantext.Prelude
+--import Data.Tuple.Extra (swap)
+--import Gargantext.Viz.Graph
+import Data.Map (Map, fromListWith, lookup, fromList, delete, toList, mapKeys, mapWithKey, elems)
+import qualified Data.Map as DM
+import Data.Maybe (fromJust)
+import Data.List (concat, sortOn)
+import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
+
+
+-- TODO mv in Louvain Lib
+type LouvainNodeId = Int
+type CommunityId   = Int
+
+type Bridgeness = Double
+
+
+bridgeness :: Bridgeness
+           -> [LouvainNode]
+           -> Map (LouvainNodeId, LouvainNodeId) Double
+           -> Map (LouvainNodeId, LouvainNodeId) Double
+bridgeness b ns = DM.fromList
+                . concat
+                . DM.elems
+                . filterComs b
+                . groupEdges (nodeId2comId ns)
+
+nodeId2comId :: [LouvainNode] -> Map LouvainNodeId CommunityId
+nodeId2comId ns = fromList [ (nId,cId) | LouvainNode nId cId <- ns]
+
+groupEdges :: Map LouvainNodeId CommunityId
+           -> Map (LouvainNodeId, LouvainNodeId) Double
+           -> Map (CommunityId, CommunityId) [((LouvainNodeId, LouvainNodeId), Double)]
+groupEdges m = mapKeys fromJust
+             . delete Nothing
+             . fromListWith (<>)
+             . map (\((n1,n2), d)
+                     -> ((,) <$> lookup n1 m
+                             <*> lookup n2 m
+                        , [((n1,n2),d)]
+                        )
+                   )
+             . toList
+
+filterComs :: Bridgeness
+           -> Map (CommunityId, CommunityId) [((LouvainNodeId, LouvainNodeId), Double)]
+           -> Map (CommunityId, CommunityId) [((LouvainNodeId, LouvainNodeId), Double)]
+filterComs b m = mapWithKey filter' m
+  where
+    filter' (c1,c2) a = case c1 == c2 of
+      True  -> a
+      False -> take n $ sortOn snd a
+        where
+          n = round $ b * a' / t
+          a'= fromIntegral $ length a
+          t = fromIntegral $ length $ concat $ elems m
+
+

src/Gargantext/Viz/Graph/Utils.hs

 {-|
-Module      : Gargantext.Graph.Distances.Utils
+Module      : Gargantext.Viz.Graph.Utils
 Description : 
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3