[FLOW PHYLO] Compiles but errors at runtime test.

src/Gargantext/API/Ngrams/Tools.hs

@@ -49,19 +49,19 @@ getListNgrams nodeIds ngramsType = do
 
   pure ngrams
 
-getTermsWith :: RepoCmdM env err m
-          => [ListId]
+getTermsWith :: (RepoCmdM env err m, Ord a)
+          => (Text -> a ) -> [ListId]
           -> NgramsType -> ListType
-          -> m (Map Text [Text])
-getTermsWith ls ngt lt = Map.fromListWith (<>)
-                      <$> map toTree
+          -> m (Map a [a])
+getTermsWith f ls ngt lt = Map.fromListWith (<>)
+                      <$> map (toTreeWith f)
                       <$> Map.toList
                       <$> Map.filter (\f -> (fst f) == lt)
                       <$> mapTermListRoot ls ngt
   where
-    toTree (t, (_lt, maybeRoot)) = case maybeRoot of
-      Nothing -> (t, [])
-      Just  r -> (r, [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/Schema/NodeNode.hs

@@ -149,6 +149,19 @@ queryDocs cId = proc () -> do
   returnA -< view (node_hyperdata) n
 
 
+selectDocNodes :: CorpusId -> Cmd err [NodeDocument]
+selectDocNodes cId = runOpaQuery (queryDocNodes cId)
+
+queryDocNodes :: CorpusId -> O.Query NodeRead
+queryDocNodes cId = proc () -> do
+  (n, nn) <- joinInCorpus -< ()
+  restrict -< ( nn_node1_id nn)  .== (toNullable $ pgNodeId cId)
+  restrict -< ( nn_delete nn)    .== (toNullable $ pgBool False)
+  restrict -< (_node_typename n) .== (pgInt4 $ nodeTypeId NodeDocument)
+  returnA -<  n
+
+
+
 joinInCorpus :: O.Query (NodeRead, NodeNodeReadNull)
 joinInCorpus = leftJoin queryNodeTable queryNodeNodeTable cond
   where

src/Gargantext/Viz/Phylo/Main.hs

+{-|
+Module      : Gargantext.Viz.Phylo.Main
+Description : Phylomemy Main
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+
+-}
+
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE ViewPatterns      #-}
+
+module Gargantext.Viz.Phylo.Main
+  where
+
+--import Debug.Trace (trace)
+import qualified Data.Text as Text
+import Data.Maybe
+import Servant
+import GHC.IO (FilePath)
+import Data.GraphViz
+import Gargantext.Prelude
+import Gargantext.Text.Context (TermList)
+import qualified Data.Map  as Map
+import qualified Data.List as List
+import qualified Data.Set  as Set
+import Gargantext.Viz.Phylo.View.Export
+import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.LevelMaker
+import Gargantext.Core.Types
+import Gargantext.Database.Config (userMaster)
+import Gargantext.Database.Schema.Node (defaultList)
+import Gargantext.Database.Schema.NodeNode (selectDocNodes)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Node.Select (selectNodesWithUsername)
+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 Control.Monad.IO.Class (liftIO)
+
+type MinSizeBranch = Int
+
+flowPhylo :: FlowCmdM env ServantErr m
+          => CorpusId
+          -> 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
+  --printDebug "termList" termList
+  
+  --x <- mapTermListRoot [list] NgramsTerms
+  --printDebug "mapTermListRoot" x
+  
+  -- TODO optimize unwords
+  let terms = Set.map Text.unwords
+            $ Set.fromList
+            $ List.concat
+            $ map (\(a,b) -> [a] <> b) termList
+  
+      getDate n = maybe (panic "flowPhylo") identity
+             $ _hyperdataDocument_publication_year
+             $ _node_hyperdata n
+  
+  --printDebug "terms" terms
+
+  -- TODO optimize this Database function below
+  docs' <- map (\n -> (_node_id n, getDate n)) <$> selectDocNodes cId
+  --printDebug "docs'" docs'
+
+  nidTerms' <- getNodesByNgramsOnlyUser cId (listMaster <> [list]) NgramsTerms (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 docs = map (\(n,d) -> Document d (maybe [] identity $ Map.lookup n nidTerms)) docs'
+  printDebug "docs" docs
+  printDebug "docs" termList
+
+  liftIO $ flowPhylo' docs termList l m fp
+
+
+flowPhylo' :: [Document] -> TermList      -- ^Build
+          -> Level      -> MinSizeBranch -- ^View
+          -> FilePath
+          -> IO FilePath
+flowPhylo' corpus terms l m fp = do
+  let
+    phylo = buildPhylo corpus terms
+    phVie = viewPhylo  l m phylo
+
+  writePhylo fp phVie
+
+
+defaultQuery :: PhyloQueryBuild
+defaultQuery = defaultQueryBuild'
+  "Default Title"
+  "Default Description"
+
+buildPhylo :: [Document] -> TermList -> Phylo
+buildPhylo = buildPhylo' defaultQuery
+
+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
+           [BranchAge]
+           [SizeBranch $ SBParams minSizeBranch]
+           [BranchPeakFreq,GroupLabelCooc]
+           (Just (ByBranchAge,Asc))
+           Json Flat True
+
+viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
+viewPhylo l b phylo = toPhyloView (queryView l b) phylo
+
+writePhylo :: FilePath -> PhyloView -> IO FilePath
+writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
+