[PHYLO] backend POST/GET DB written.

src/Gargantext/API.hs

@@ -321,7 +321,7 @@ serverGargAPI -- orchestrator
      :<|> New.info fakeUserId
   --   :<|> orchestrator
   where
-    fakeUserId = 1 -- TODO
+    fakeUserId = 2 -- TODO, byDefault user1 (if users automatically generated with inserUsersDemo)
 
 serverStatic :: Server (Get '[HTML] Html)
 serverStatic = $(do

src/Gargantext/API/Node.hs

@@ -183,7 +183,7 @@ nodeAPI p uId id
            :<|> getChart id
            :<|> getPie   id
            :<|> getTree  id
-           :<|> phyloAPI id
+           :<|> phyloAPI id uId
            :<|> postUpload id
   where
     deleteNodeApi id' = do

src/Gargantext/Database/Schema/Node.hs

@@ -43,6 +43,7 @@ import Gargantext.Database.Queries.Filter (limit', offset')
 import Gargantext.Database.Types.Node (NodeType, defaultCorpus, Hyperdata)
 import Gargantext.Database.Utils
 import Gargantext.Prelude hiding (sum, head)
+
 import Opaleye hiding (FromField)
 import Opaleye.Internal.QueryArr (Query)
 import Prelude hiding (null, id, map, sum)
@@ -374,6 +375,13 @@ getNode nId _ = do
     fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 
+getNodePhylo :: NodeId -> Cmd err (NodePhylo)
+getNodePhylo nId = do
+    fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
+             <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
+
+
+
 getNode' :: NodeId -> Cmd err (Node Value)
 getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
@@ -462,7 +470,7 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
 
 ------------------------------------------------------------------------
 arbitraryPhylo :: HyperdataPhylo
-arbitraryPhylo = HyperdataPhylo (Just "Preferences")
+arbitraryPhylo = HyperdataPhylo Nothing Nothing
 
 nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
 nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)

src/Gargantext/Database/Types/Node.hs

@@ -57,6 +57,7 @@ import           Test.QuickCheck (elements)
 
 import           Gargantext.Prelude
 import           Gargantext.Core.Utils.Prefix (unPrefix)
+import           Gargantext.Viz.Phylo (Phylo)
 --import Gargantext.Database.Utils
 ------------------------------------------------------------------------
 newtype NodeId = NodeId Int
@@ -384,6 +385,7 @@ instance Hyperdata HyperdataGraph
 
 -- TODO add the Graph Structure here
 data HyperdataPhylo = HyperdataPhylo { hyperdataPhylo_preferences   :: !(Maybe Text)
+                                     , hyperdataPhylo_data          :: !(Maybe Phylo)
                                    } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataPhylo_") ''HyperdataPhylo)
 

src/Gargantext/Text/List.hs

@@ -59,9 +59,9 @@ data StopSize = StopSize {unStopSize :: Int}
 -- | TODO improve grouping functions of Authors, Sources, Institutes..
 buildNgramsLists :: Lang -> Int -> Int -> StopSize -> UserCorpusId -> MasterCorpusId
                  -> Cmd err (Map NgramsType [NgramsElement])
-buildNgramsLists l n m s uCid mCid = do
-  ngTerms     <- buildNgramsTermsList l n m s uCid mCid
-  --ngTerms     <- buildNgramsTermsList' uCid (ngramsGroup l n m) (isStopTerm s . fst) 550 300
+buildNgramsLists l n m s uCid _mCid = do
+  --ngTerms     <- buildNgramsTermsList l n m s uCid mCid
+  ngTerms     <- buildNgramsTermsList' uCid (ngramsGroup l n m) (isStopTerm s . fst) 500 50
   othersTerms <- mapM (buildNgramsOthersList uCid identity) [Authors, Sources, Institutes]
   pure $ Map.unions $ othersTerms <> [ngTerms]
 

src/Gargantext/Text/Metrics.hs

@@ -108,7 +108,7 @@ linearTakes gls incSize speGen incExc = (List.splitAt gls)
                                   $ (fromIntegral gls     :: Double)
                                   / (fromIntegral incSize :: Double)
                              )
-                      . map (sortOn incExc)
+                      . map (sortOn speGen)
                       . splitEvery incSize
-                      . sortOn speGen
+                      . sortOn incExc
 

src/Gargantext/Viz/Phylo/API.hs

@@ -27,20 +27,16 @@ import Data.String.Conversions
 --import Control.Monad.Reader (ask)
 import qualified Data.ByteString as DB
 import qualified Data.ByteString.Lazy as DBL
-import Data.Text (Text)
-import Data.Map  (empty)
 import Data.Swagger
 import Gargantext.API.Types
 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
+import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo)
+import Gargantext.Database.Types.Node -- (NodePhylo(..))
 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.API.Ngrams (TODO(..))
---import Gargantext.Viz.Phylo.View.ViewMaker
-import Gargantext.Viz.Phylo.LevelMaker
 import Servant
 import Servant.Job.Utils (swaggerOptions)
 import Test.QuickCheck (elements)
@@ -56,10 +52,11 @@ type PhyloAPI = Summary "Phylo API"
             :<|> PostPhylo
 
 
-phyloAPI :: PhyloId -> GargServer PhyloAPI
-phyloAPI n = getPhylo'  n
+phyloAPI :: PhyloId -> UserId -> GargServer PhyloAPI
+phyloAPI n u = getPhylo  n
+        :<|> postPhylo n u
         -- :<|> putPhylo  n
-        :<|> postPhylo n
+        -- :<|> deletePhylo  n
 
 newtype SVG = SVG DB.ByteString
 
@@ -82,6 +79,7 @@ instance MimeRender SVG SVG where
 ------------------------------------------------------------------------
 type GetPhylo =  QueryParam "listId"      ListId
               :> QueryParam "level"       Level
+              :> QueryParam "minSizeBranch" MinSizeBranch
               :> QueryParam "filiation"   Filiation
               :> QueryParam "childs"      Bool
               :> QueryParam "depth"       Level
@@ -100,50 +98,44 @@ type GetPhylo =  QueryParam "listId"      ListId
 -- | 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
+getPhylo phId _lId l msb _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
+  phNode     <- getNodePhylo phId
+
   let
-    fs' = maybe (Just []) (\p -> Just [p]) $ LonelyBranch <$> (LBParams <$> x <*> y <*> z)
-    so  = (,) <$> s <*> o
-    q = initPhyloQueryView l f b l' ms fs' ts so e d b'
-  -- | TODO remove phylo for real data here
-  pure (toPhyloView  q phylo)
-  -- TODO remove phylo for real data here
--}
+    level = maybe 1 identity l
+    branc = maybe 2 identity msb
+    maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
 
-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
+  p <- liftIO $ viewPhylo2Svg $ viewPhylo level branc  $ maybe phyloFromQuery identity maybePhylo
   pure (SVG p)
 ------------------------------------------------------------------------
-{-
-type PutPhylo = (Put '[JSON] Phylo  )
---putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
-putPhylo :: PhyloId -> GargServer PutPhylo
-putPhylo = undefined
--}
-------------------------------------------------------------------------
 type PostPhylo =  QueryParam "listId" ListId
                :> ReqBody '[JSON] PhyloQueryBuild
-               :> (Post '[JSON] Phylo)
+               :> (Post '[JSON] NodeId)
 
-postPhylo :: CorpusId -> GargServer PostPhylo
-postPhylo _n _lId q = do
+postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
+postPhylo n userId _lId _q = do
   -- TODO get Reader settings
   -- s <- ask
   let
-    vrs = Just ("1" :: Text)
-    sft = Just (Software "Gargantext" "4")
-    prm = initPhyloParam vrs sft (Just q)
-  pure (toPhyloBase q prm (parseDocs (initFoundationsRoots actants) corpus) termList empty)
-
+    -- _vrs = Just ("1" :: Text)
+    -- _sft = Just (Software "Gargantext" "4")
+    -- _prm = initPhyloParam vrs sft (Just q)
+  ph <- flowPhylo n
+  pId <- insertNodes [nodePhyloW (Just "Phylo") (Just $ HyperdataPhylo Nothing (Just ph)) n userId]
+  pure $ NodeId (fromIntegral pId)
 
 ------------------------------------------------------------------------
 -- | DELETE Phylo == delete a node
 ------------------------------------------------------------------------
-
-
+------------------------------------------------------------------------
+{-
+type PutPhylo = (Put '[JSON] Phylo  )
+--putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
+putPhylo :: PhyloId -> GargServer PutPhylo
+putPhylo = undefined
+-}
 
 
 -- | Instances
@@ -160,7 +152,6 @@ instance Arbitrary Phylo
   where
     arbitrary = elements [phylo]
 
-
 instance ToSchema Cluster
 instance ToSchema EdgeType
 instance ToSchema Filiation

src/Gargantext/Viz/Phylo/Main.hs

@@ -46,51 +46,35 @@ import qualified Data.Text as Text
 
 type MinSizeBranch = Int
 
-flowPhylo :: FlowCmdM env ServantErr m
+flowPhylo :: FlowCmdM env err m
           => CorpusId
-          -> Level -> MinSizeBranch
-          -> FilePath
-          -> m FilePath
-flowPhylo cId l m fp = do
+          -> m Phylo
+flowPhylo cId = 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
-
-  docs' <- catMaybes <$> map (\h -> (,) <$> _hyperdataDocument_publication_year h
-                          <*> _hyperdataDocument_abstract h
-                          ) <$> selectDocs cId
-  
-  let patterns = buildPatterns termList
-  let docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
-  --printDebug "docs" docs
-  --printDebug "docs" termList
-
-  liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
-
-
 
+  docs' <- catMaybes
+          <$> map (\h -> (,) <$> _hyperdataDocument_publication_year h
+                             <*> _hyperdataDocument_abstract h
+                  )
+          <$> selectDocs cId
 
-parse :: TermList -> [(Date, Text)] -> IO [Document]
-parse l c = do
-  let patterns = buildPatterns l
-  pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) c
-
-
--- | To filter the Ngrams of a document based on the termList
-filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
-filterTerms patterns (y,d) = (y,termsInText patterns d)
-  where
-    --------------------------------------
-    termsInText :: Patterns -> Text -> [Text]
-    termsInText pats txt = List.nub $ List.concat $ map (map Text.unwords) $ extractTermsWithList pats txt
-    --------------------------------------
+  let
+    patterns = buildPatterns termList
+    -- | To filter the Ngrams of a document based on the termList
+    filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
+    filterTerms patterns (y,d) = (y,termsInText patterns d)
+      where
+        --------------------------------------
+        termsInText :: Patterns -> Text -> [Text]
+        termsInText pats txt = List.nub $ List.concat $ map (map Text.unwords) $ extractTermsWithList pats txt
+        --------------------------------------
+
+    docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
+
+  --liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
+  pure $ buildPhylo (List.sortOn date docs) termList
 
 
 -- TODO SortedList Document