[PHYLO) Backend + flowPhylo + SVG.

devops/debianPkgs

@@ -10,5 +10,9 @@ fi
 
 sudo apt update
 sudo apt install liblzma-dev libpcre3-dev libblas-dev liblapack-dev pkg-config libgsl-dev libbz2-dev postgresql nginx libpq-dev libigraph0-dev
+
+# Phylo management
+sudo apt install graphviz
+
 sudo apt install postgresql-server-dev-9.6 
 

package.yaml

@@ -122,6 +122,7 @@ library:
   - http-client
   - http-client-tls
   - http-conduit
+  - http-media
   - http-api-data
   - http-types
   - hsparql

src/Gargantext/API/Ngrams/Tools.hs

@@ -56,12 +56,12 @@ getTermsWith :: (RepoCmdM env err m, Ord a)
 getTermsWith f ls ngt lt = Map.fromListWith (<>)
                       <$> map (toTreeWith f)
                       <$> Map.toList
-                      <$> Map.filter (\f -> (fst f) == lt)
+                      <$> Map.filter (\f' -> (fst f') == lt)
                       <$> mapTermListRoot ls ngt
   where
-    toTreeWith f (t, (_lt, maybeRoot)) = case maybeRoot of
-      Nothing -> (f t, [])
-      Just  r -> (f r, map f [t])
+    toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
+      Nothing -> (f'' t, [])
+      Just  r -> (f'' r, map f'' [t])
 
 mapTermListRoot :: RepoCmdM env err m
                => [ListId] -> NgramsType

src/Gargantext/Database/Config.hs

@@ -57,6 +57,7 @@ nodeTypeId n =
 ----  Scores
 --    NodeOccurrences -> 10
     NodeGraph       -> 9
+    NodePhylo       -> 90
     NodeDashboard   -> 7
     NodeChart       -> 51
 

src/Gargantext/Database/Flow.hs

@@ -52,7 +52,7 @@ import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..)
 import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
 import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
-import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
+import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, mkPhylo, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
 import Gargantext.Database.Schema.User (getUser, UserLight(..))
 import Gargantext.Database.TextSearch (searchInDatabase)
 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
@@ -190,6 +190,7 @@ flowCorpusUser l userName corpusName ctype ids = do
   printDebug "userListId" userListId
   -- User Graph Flow
   _ <- mkGraph  userCorpusId userId
+  _ <- mkPhylo  userCorpusId userId
   --}
 
   -- User Dashboard Flow

src/Gargantext/Database/Schema/Node.hs

@@ -103,6 +103,10 @@ instance FromField HyperdataGraph
   where
     fromField = fromField'
 
+instance FromField HyperdataPhylo
+  where
+    fromField = fromField'
+
 instance FromField HyperdataAnnuaire
   where
     fromField = fromField'
@@ -143,6 +147,10 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
   where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
 
+instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
+  where
+    queryRunnerColumnDefault = fieldQueryRunnerColumn
+
 instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
   where
     queryRunnerColumnDefault = fieldQueryRunnerColumn
@@ -452,6 +460,17 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
     name = maybe "Graph" identity maybeName
     graph = maybe arbitraryGraph identity maybeGraph
 
+------------------------------------------------------------------------
+arbitraryPhylo :: HyperdataPhylo
+arbitraryPhylo = HyperdataPhylo (Just "Preferences")
+
+nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
+nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
+  where
+    name = maybe "Phylo" identity maybeName
+    graph = maybe arbitraryPhylo identity maybePhylo
+
+
 ------------------------------------------------------------------------
 
 arbitraryDashboard :: HyperdataDashboard
@@ -603,6 +622,9 @@ mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 
+mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
+mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
+
 -- | Default CorpusId Master and ListId Master
 
 pgNodeId :: NodeId -> Column PGInt4

src/Gargantext/Database/Tree.hs

@@ -98,7 +98,7 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGS
         FROM nodes AS c
         
         INNER JOIN tree AS s ON c.parent_id = s.id
-        WHERE c.typename IN (2,3,30,31,7,9)
+        WHERE c.typename IN (2,3,30,31,7,9,90)
       )
   SELECT * from tree;
   |] (Only rootId)

src/Gargantext/Database/Types/Node.hs

@@ -379,6 +379,7 @@ data HyperdataGraph = HyperdataGraph { hyperdataGraph_preferences   :: !(Maybe T
 $(deriveJSON (unPrefix "hyperdataGraph_") ''HyperdataGraph)
 
 instance Hyperdata HyperdataGraph
+
 ------------------------------------------------------------------------
 
 -- TODO add the Graph Structure here
@@ -429,7 +430,7 @@ data NodeType = NodeUser
               | NodeFolder
               | NodeCorpus     | NodeCorpusV3 | NodeDocument
               | NodeAnnuaire   | NodeContact
-              | NodeGraph
+              | NodeGraph      | NodePhylo
               | NodeDashboard  | NodeChart
               | NodeList       | NodeListModel deriving (Show, Read, Eq, Generic, Bounded, Enum)
 

src/Gargantext/Viz/Phylo/API.hs

@@ -9,10 +9,8 @@ Portability : POSIX
 
 -}
 
-
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-
 {-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE NoImplicitPrelude  #-}
@@ -20,11 +18,13 @@ Portability : POSIX
 {-# LANGUAGE OverloadedLists    #-}   -- allows to write Map and HashMap as lists
 {-# LANGUAGE TypeOperators      #-}
 {-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Gargantext.Viz.Phylo.API
   where
 
 --import Control.Monad.Reader (ask)
+import qualified Data.ByteString as DB
 import Data.Text (Text)
 import Data.Map  (empty)
 import Data.Swagger
@@ -32,16 +32,19 @@ import Gargantext.API.Types
 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Main
 import Gargantext.Viz.Phylo.Aggregates
 import Gargantext.Viz.Phylo.Example
 import Gargantext.Viz.Phylo.Tools
-import Gargantext.Viz.Phylo.View.ViewMaker
+--import Gargantext.Viz.Phylo.View.ViewMaker
 import Gargantext.Viz.Phylo.LevelMaker
 import Servant
 import Servant.Job.Utils (swaggerOptions)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import Web.HttpApiData (parseUrlPiece, readTextData)
+import Control.Monad.IO.Class (liftIO)
+import Network.HTTP.Media ((//), (/:))
 
 ------------------------------------------------------------------------
 type PhyloAPI = Summary "Phylo API"
@@ -51,10 +54,29 @@ type PhyloAPI = Summary "Phylo API"
 
 
 phyloAPI :: PhyloId -> GargServer PhyloAPI
-phyloAPI n = getPhylo  n
+phyloAPI n = getPhylo'  n
         -- :<|> putPhylo  n
         :<|> postPhylo n
 
+newtype SVG = SVG DB.ByteString
+
+instance ToSchema SVG
+  where
+    declareNamedSchema = undefined
+    --genericDeclareNamedSchemaUnrestricted (swaggerOptions "")
+
+instance Show SVG where
+  show (SVG a) = show a
+
+instance Accept SVG where
+   contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
+
+instance Show a => MimeRender PlainText a where
+   mimeRender _ val = cs ("" <> show val)
+
+instance Show a => MimeRender SVG a where
+   mimeRender _ val = cs ("" <> show val)
+
 ------------------------------------------------------------------------
 type GetPhylo =  QueryParam "listId"      ListId
               :> QueryParam "level"       Level
@@ -71,11 +93,12 @@ type GetPhylo =  QueryParam "listId"      ListId
               :> QueryParam "export"    ExportMode
               :> QueryParam "display"    DisplayMode
               :> QueryParam "verbose"     Bool
-              :> Get '[JSON] PhyloView
+              :> Get '[SVG] SVG
 
 -- | TODO
 -- Add real text processing
 -- Fix Filter parameters
+{-
 getPhylo :: PhyloId -> GargServer GetPhylo
 getPhylo _phyloId _lId l f b l' ms x y z ts s o e d b' = do
   let
@@ -85,7 +108,12 @@ getPhylo _phyloId _lId l f b l' ms x y z ts s o e d b' = do
   -- | TODO remove phylo for real data here
   pure (toPhyloView  q phylo)
   -- TODO remove phylo for real data here
+-}
 
+getPhylo' :: PhyloId -> GargServer GetPhylo
+getPhylo' _phyloId _lId _l _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
+  p <- liftIO $ viewPhylo2Svg phyloView
+  pure (SVG p)
 ------------------------------------------------------------------------
 {-
 type PutPhylo = (Put '[JSON] Phylo  )

src/Gargantext/Viz/Phylo/Aggregates.hs

@@ -43,17 +43,15 @@ import qualified Data.Vector as Vector
 -- | Foundations | --
 ---------------------
 
-
 -- | Extract all the labels of a termList
 termListToNgrams :: TermList -> [Ngrams]
-termListToNgrams l = map (\(lbl,_) -> unwords lbl) l
+termListToNgrams = map (\(lbl,_) -> unwords lbl)
 
 
 -------------------
 -- | Documents | --
 -------------------
 
-
 -- | To group a list of Documents by fixed periods
 groupDocsByPeriod :: (Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
 groupDocsByPeriod _ _   [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
@@ -84,7 +82,7 @@ countDocs corpus = fromListWith (+) $ map (\(d,_) -> (d,1)) corpus
 
 -- | To init a list of Periods framed by a starting Date and an ending Date
 initPeriods :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
-initPeriods g s (start,end) = map (\l -> (head' "Doc" l, last' "Doc" l))
+initPeriods g s (start,end) = map (\l -> (head' "initPeriods" l, last' "initPeriods" l))
                             $ chunkAlong g s [start .. end]
 
 
@@ -220,4 +218,4 @@ traceFis lbl m = trace (lbl <> "count : " <> show (sum $ map length $ elems m) <
     --------------------------------------
     ngrms :: [Double]
     ngrms = sort $ map (\f -> fromIntegral $ size $ _phyloFis_clique f) $ concat $ elems m
-    --------------------------------------
+    --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Example.hs

@@ -28,7 +28,6 @@ TODO:
 
 module Gargantext.Viz.Phylo.Example where
 
-import Data.GraphViz.Types.Generalised (DotGraph)
 import Data.Text (Text, toLower)
 import Data.List        ((++))
 import Data.Map         (Map,empty)
@@ -44,7 +43,8 @@ import Gargantext.Viz.Phylo.LevelMaker
 import Gargantext.Viz.Phylo.LinkMaker
 import Gargantext.Viz.Phylo.Tools
 import Gargantext.Viz.Phylo.View.ViewMaker
-import Gargantext.Viz.Phylo.View.Export
+import Gargantext.Viz.Phylo.Main (writePhylo)
+import GHC.IO (FilePath)
 import qualified Data.List   as List
 
 
@@ -52,11 +52,9 @@ import qualified Data.List   as List
 -- | STEP 12 | -- Create a PhyloView from a user Query
 ------------------------------------------------------
 
-export :: IO ()
-export = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre.dot" phyloDot 
 
-phyloDot :: DotGraph DotId
-phyloDot = viewToDot phyloView
+phyloExport :: FilePath -> IO FilePath
+phyloExport fp = writePhylo fp phyloView
 
 phyloView :: PhyloView
 phyloView = toPhyloView (queryParser' queryViewEx) phyloFromQuery

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -259,14 +259,14 @@ toPhyloBase q p c termList fis = initPhyloBase periods foundations nbDocs cooc f
     cooc = docsToCooc c (foundations ^. phylo_foundationsRoots)
     --------------------------------------
     nbDocs :: Map Date Double
-    nbDocs = countDocs $ map (\doc -> (date doc, text doc)) c        
+    nbDocs = countDocs $ map (\doc -> (date doc, text doc)) c
     --------------------------------------
     foundations :: PhyloFoundations
     foundations = PhyloFoundations (initFoundationsRoots (termListToNgrams termList)) termList
     --------------------------------------
     periods :: [(Date,Date)]
     periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
-            $ both date (head' "LevelMaker" c,last c)
+            $ both date (head' "toPhyloBase" c, last' "toPhyloBase" c)
     --------------------------------------
 
 

src/Gargantext/Viz/Phylo/Main.hs

@@ -44,8 +44,9 @@ import Gargantext.Database.Flow
 import Gargantext.API.Ngrams.Tools (getTermsWith)
 -- TODO : git mv ViewMaker Maker
 import Gargantext.Viz.Phylo.View.ViewMaker
-import Gargantext.Viz.Phylo hiding (Svg)
+import Gargantext.Viz.Phylo hiding (Svg, Dot)
 import Control.Monad.IO.Class (liftIO)
+import qualified Data.ByteString as DB
 
 type MinSizeBranch = Int
 
@@ -54,26 +55,24 @@ flowPhylo :: FlowCmdM env ServantErr m
           -> Level -> MinSizeBranch
           -> FilePath
           -> m FilePath
-
 flowPhylo cId l m fp = do
 
   list       <- defaultList cId
   listMaster <- selectNodesWithUsername NodeList userMaster
-  termList <- Map.toList <$> getTermsWith (Text.words) [list] NgramsTerms GraphTerm
+  termList <- Map.toList <$> getTermsWith Text.words [list] NgramsTerms GraphTerm
   --printDebug "termList" termList
   
   --x <- mapTermListRoot [list] NgramsTerms
   --printDebug "mapTermListRoot" x
   
   -- TODO optimize unwords
-  let terms = Set.map Text.unwords
-            $ Set.fromList
+  let terms = Set.fromList
             $ List.concat
             $ map (\(a,b) -> [a] <> b) termList
   
       getDate n = maybe (panic "flowPhylo") identity
-             $ _hyperdataDocument_publication_year
-             $ _node_hyperdata n
+                $ _hyperdataDocument_publication_year
+                $ _node_hyperdata n
   
   --printDebug "terms" terms
 
@@ -81,21 +80,27 @@ flowPhylo cId l m fp = do
   docs' <- map (\n -> (_node_id n, getDate n)) <$> selectDocNodes cId
   --printDebug "docs'" docs'
 
-  nidTerms' <- getNodesByNgramsOnlyUser cId (listMaster <> [list]) NgramsTerms (Set.toList terms)
+  nidTerms' <- getNodesByNgramsOnlyUser cId (listMaster <> [list])
+                                        NgramsTerms
+                                        (map Text.unwords $ Set.toList terms)
 
-  let nidTerms = Map.fromListWith (<>)
-          $ List.concat
-          $ map (\(t, ns) -> List.zip (Set.toList ns) (List.repeat $ Text.words t))
-          $ Map.toList
-          $ nidTerms'
+  let nidTerms = Map.fromList
+               $ List.concat
+               $ map (\(t, ns) -> List.zip (Set.toList ns) (List.repeat t))
+               $ Map.toList
+               $ nidTerms'
 
-  let docs = map (\(n,d) -> Document d (maybe [] identity $ Map.lookup n nidTerms)) docs'
+  let docs = List.sortOn date
+           $ List.filter (\d -> text d /= [])
+           $ map (\(n,d) -> Document d (maybe [] (\x -> [x])
+           $ Map.lookup n nidTerms)) docs'
+  
   printDebug "docs" docs
   printDebug "docs" termList
 
   liftIO $ flowPhylo' docs termList l m fp
 
-
+-- TODO SortedList Document
 flowPhylo' :: [Document] -> TermList      -- ^Build
           -> Level      -> MinSizeBranch -- ^View
           -> FilePath
@@ -120,9 +125,10 @@ buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 
 queryView :: Level -> MinSizeBranch -> PhyloQueryView
-queryView level minSizeBranch = PhyloQueryView level Merge False 1
+queryView level _minSizeBranch = PhyloQueryView level Merge False 2
            [BranchAge]
-           [SizeBranch $ SBParams minSizeBranch]
+           []
+           -- [SizeBranch $ SBParams minSizeBranch]
            [BranchPeakFreq,GroupLabelCooc]
            (Just (ByBranchAge,Asc))
            Json Flat True
@@ -133,3 +139,6 @@ viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 writePhylo :: FilePath -> PhyloView -> IO FilePath
 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 
+viewPhylo2Svg :: PhyloView -> IO DB.ByteString
+viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
+

src/Gargantext/Viz/Phylo/Tools.hs

@@ -238,19 +238,18 @@ getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 getIdxInRoots :: Ngrams -> Phylo -> Int
 getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
-    Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
+    Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
     Just idx -> idx
 
 getIdxInVector :: Ngrams -> Vector Ngrams -> Int
 getIdxInVector n ns = case (elemIndex n ns) of
-  Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
-  Just idx -> idx 
+  Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInVector] Ngrams not in foundationsRoots: " <> cs n
+  Just idx -> idx
 
 --------------------
 -- | PhyloGroup | --
 --------------------
 
-
 -- | To alter a PhyloGroup matching a given Level
 alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
 alterGroupWithLevel f lvl p = over ( phylo_periods
@@ -261,7 +260,7 @@ alterGroupWithLevel f lvl p = over ( phylo_periods
                                    .  traverse
                                    ) (\g -> if getGroupLevel g == lvl
                                             then f g
-                                            else g ) p                          
+                                            else g ) p
 
 
 -- | To alter each list of PhyloGroups following a given function