Merge branch 'dev' into 111-dev-refactor-text-corpus-api-with-conduit

CHANGELOG.md

+## Version 0.0.5.6.3
+* [BACK][EXPORT][GEXF] node size
+
+## Version 0.0.5.6.2
+* [FRONT][FIX] Ngrams Batch change
+
 ## Version 0.0.5.6.1
 * [BACK][FEAT] Confluence Method connection
 

bin/gargantext-phylo/Main.hs

@@ -136,7 +136,7 @@ fileToDocs' parser path time lst = do
 
 
 -- Config time parameters to label
-timeToLabel :: Config -> [Char]
+timeToLabel :: PhyloConfig -> [Char]
 timeToLabel config = case (timeUnit config) of
       Epoch p s f -> ("time_epochs" <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
       Year  p s f -> ("time_years"  <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
@@ -145,37 +145,37 @@ timeToLabel config = case (timeUnit config) of
       Day   p s f -> ("time_days"   <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 
 
-seaToLabel :: Config -> [Char]
+seaToLabel :: PhyloConfig -> [Char]
 seaToLabel config = case (seaElevation config) of
       Constante start step   -> ("sea_cst_"  <> (show start) <> "_" <> (show step))
       Adaptative granularity -> ("sea_adapt" <> (show granularity))
 
 
-sensToLabel :: Config -> [Char]
+sensToLabel :: PhyloConfig -> [Char]
 sensToLabel config = case (phyloProximity config) of
       Hamming _ -> undefined
       WeightedLogJaccard s -> ("WeightedLogJaccard_"  <> show s)
       WeightedLogSim s -> ( "WeightedLogSim-sens_"  <> show s)
 
 
-cliqueToLabel :: Config -> [Char]
+cliqueToLabel :: PhyloConfig -> [Char]
 cliqueToLabel config = case (clique config) of
       Fis s s' -> "fis_" <> (show s) <> "_" <> (show s')
       MaxClique s t f ->  "clique_" <> (show s)<> "_"  <> (show f)<> "_"  <> (show t)
 
 
-syncToLabel :: Config -> [Char]
+syncToLabel :: PhyloConfig -> [Char]
 syncToLabel config = case (phyloSynchrony config) of
       ByProximityThreshold scl sync_sens scope _ -> ("scale_" <> (show scope) <> "_" <> (show sync_sens)  <> "_"  <> (show scl))
       ByProximityDistribution _ _ -> undefined
 
-qualToConfig :: Config -> [Char]
+qualToConfig :: PhyloConfig -> [Char]
 qualToConfig config = case (phyloQuality config) of
       Quality g m -> "quality_" <> (show g) <> "_" <> (show m)
 
 
 -- To set up the export file's label from the configuration
-configToLabel :: Config -> [Char]
+configToLabel :: PhyloConfig -> [Char]
 configToLabel config = outputPath config
                     <> (unpack $ phyloName config)
                     <> "-" <> (timeToLabel config)
@@ -189,7 +189,7 @@ configToLabel config = outputPath config
 
 
 -- To write a sha256 from a set of config's parameters
-configToSha :: PhyloStage -> Config -> [Char]
+configToSha :: PhyloStage -> PhyloConfig -> [Char]
 configToSha stage config = unpack
                          $ replace "/" "-"
                          $ T.pack (show (hash $ C8.pack label))
@@ -242,7 +242,7 @@ main = do
 
     printIOMsg "Read the configuration file"
     [args]   <- getArgs
-    jsonArgs <- (eitherDecode <$> readJson args) :: IO (Either String Config)
+    jsonArgs <- (eitherDecode <$> readJson args) :: IO (Either String PhyloConfig)
 
     case jsonArgs of
         Left err     -> putStrLn err

bin/init

+#!/bin/bash
+
+ln -s $(nix-shell --run "which dot") ~/.local/bin/dot
+

package.yaml

 name: gargantext
-version: '0.0.5.6.1'
+version: '0.0.5.6.3'
 synopsis: Search, map, share
 description: Please see README.md
 category: Data

src/Gargantext/API/Node/DocumentUpload.hs

@@ -69,21 +69,32 @@ api :: UserId -> NodeId -> GargServer API
 api uId nId =
   serveJobsAPI $
     JobFunction (\q log' -> do
-      documentUpload uId nId q (liftBase . log')
+      documentUploadAsync uId nId q (liftBase . log')
     )
 
-documentUpload :: (FlowCmdM env err m)
+documentUploadAsync :: (FlowCmdM env err m)
                => UserId
                -> NodeId
                -> DocumentUpload
                -> (JobLog -> m ())
                -> m JobLog
-documentUpload _uId nId doc logStatus = do
+documentUploadAsync _uId nId doc logStatus = do
   let jl = JobLog { _scst_succeeded = Just 0
                   , _scst_failed    = Just 0
                   , _scst_remaining = Just 1
                   , _scst_events    = Just [] }
   logStatus jl
+  docIds <- documentUpload nId doc
+  printDebug "documentUploadAsync" docIds
+  pure $ jobLogSuccess jl
+
+
+
+documentUpload :: (FlowCmdM env err m)
+               => NodeId
+               -> DocumentUpload
+               -> m [DocId]
+documentUpload nId doc = do
   mcId <- getClosestParentIdByType' nId NodeCorpus
   let cId = case mcId of
         Just c  -> c
@@ -116,5 +127,6 @@ documentUpload _uId nId doc logStatus = do
   
   docIds <- insertMasterDocs (Nothing :: Maybe HyperdataCorpus) (Multi EN) [hd]
   _ <- Doc.add cId docIds
+  pure docIds
+
 
-  pure $ jobLogSuccess jl

src/Gargantext/API/Node/Update.hs

@@ -29,12 +29,14 @@ import Gargantext.Core.Methods.Distances (GraphMetric(..))
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
 import Gargantext.Core.Viz.Graph.Tools (PartitionMethod(..))
+import Gargantext.Core.Viz.Phylo (PhyloSubConfig(..), subConfig2config)
+import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
+import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Query.Table.Node (defaultList)
-import Gargantext.Database.Query.Table.Node (getNode)
+import Gargantext.Database.Query.Table.Node (defaultList, getNode, insertNodes, node)
 import Gargantext.Database.Schema.Ngrams (NgramsType(NgramsTerms))
 import Gargantext.Database.Schema.Node (node_parent_id)
 import Gargantext.Prelude (Bool(..), Ord, Eq, (<$>), ($), liftBase, (.), printDebug, pure, show, cs, (<>), panic, (<*>))
@@ -54,12 +56,19 @@ type API = Summary " Update node according to NodeType params"
 
 ------------------------------------------------------------------------
 data UpdateNodeParams = UpdateNodeParamsList  { methodList  :: !Method      }
+
                       | UpdateNodeParamsGraph { methodGraphMetric     :: !GraphMetric 
                                               , methodGraphClustering :: !PartitionMethod
                                               }
+
                       | UpdateNodeParamsTexts { methodTexts :: !Granularity }
+
                       | UpdateNodeParamsBoard { methodBoard :: !Charts      }
-                      | LinkNodeReq { nodeType :: !NodeType, id :: !NodeId }
+
+                      | LinkNodeReq           { nodeType    :: !NodeType
+                                              , id :: !NodeId }
+
+                      | UpdateNodePhylo       { config :: !PhyloSubConfig }
     deriving (Generic)
 
 ----------------------------------------------------------------------
@@ -182,6 +191,34 @@ updateNode _uId lId (UpdateNodeParamsList _mode) logStatus = do
                , _scst_events    = Just []
                }
 
+updateNode userId phyloId (UpdateNodePhylo config) logStatus = do
+  logStatus JobLog { _scst_succeeded = Just 1
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 2
+                   , _scst_events    = Just []
+                   }
+
+  corpusId' <- view node_parent_id <$> getNode phyloId
+
+  let corpusId = fromMaybe (panic "") corpusId'
+
+  phy <- flowPhyloAPI (subConfig2config config) corpusId
+
+  logStatus JobLog { _scst_succeeded = Just 2
+                   , _scst_failed    = Just 0
+                   , _scst_remaining = Just 1
+                   , _scst_events    = Just []
+                   }
+
+  _phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
+
+  pure  JobLog { _scst_succeeded = Just 3
+               , _scst_failed    = Just 0
+               , _scst_remaining = Just 0
+               , _scst_events    = Just []
+               }
+
+
 updateNode _uId tId (UpdateNodeParamsTexts _mode) logStatus = do
   logStatus JobLog { _scst_succeeded = Just 1
                    , _scst_failed    = Just 0

src/Gargantext/Core/Viz/Graph/API.hs

@@ -102,7 +102,8 @@ getGraph _uId nId = do
   case graph of
     Nothing     -> do
         let defaultMetric          = Order1
-        graph' <- computeGraph cId Spinglass (withMetric defaultMetric) NgramsTerms repo
+        let defaultPartitionMethod = Spinglass
+        graph' <- computeGraph cId defaultPartitionMethod (withMetric defaultMetric) NgramsTerms repo
         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
         let
           graph'' = set graph_metadata (Just mt) graph'

src/Gargantext/Core/Viz/Graph/GEXF.hs

@@ -52,11 +52,12 @@ instance Xmlbf.ToXml Graph where
       nodes gn = Xmlbf.element "nodes" HashMap.empty $ P.concatMap node' gn
 
       node' :: G.Node -> [Xmlbf.Node]
-      node' (G.Node { node_id = nId, node_label = l }) =
+      node' (G.Node { node_id = nId, node_label = l, node_size = w}) =
         Xmlbf.element "node" params []
         where
           params = HashMap.fromList [ ("id", nId)
-                                    , ("label", l) ]
+                                    , ("label", l) 
+                                    , ("size", (cs . show) w)]
       edges :: [G.Edge] -> [Xmlbf.Node]
       edges gn = Xmlbf.element "edges" HashMap.empty $ P.concatMap edge gn
       edge :: G.Edge -> [Xmlbf.Node]

src/Gargantext/Core/Viz/Phylo.hs

@@ -26,24 +26,24 @@ one 8, e54847.
 
 module Gargantext.Core.Viz.Phylo where
 
-import Data.Swagger
-import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Control.DeepSeq (NFData)
 import Control.Lens (makeLenses)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Map (Map)
+import Data.Swagger
 import Data.Text   (Text, pack)
 import Data.Vector (Vector)
 import GHC.Generics
 import GHC.IO (FilePath)
 import Gargantext.Core.Text.Context (TermList)
 import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
 import Gargantext.Prelude
 import qualified Data.Text.Lazy as TextLazy
 
 ----------------
--- | Config | --
+-- | PhyloConfig | --
 ----------------
 
 data CorpusParser =
@@ -180,9 +180,8 @@ instance ToSchema Quality where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_qua_")
 
 
-
-data Config =
-     Config { corpusPath     :: FilePath
+data PhyloConfig =
+     PhyloConfig { corpusPath     :: FilePath
             , listPath       :: FilePath
             , outputPath     :: FilePath
             , corpusParser   :: CorpusParser
@@ -201,12 +200,32 @@ data Config =
             , exportFilter   :: [Filter]
             } deriving (Show,Generic,Eq)
 
-instance ToSchema Config
 
+------------------------------------------------------------------------
+data PhyloSubConfig =
+  PhyloSubConfig { _sc_phyloProximity :: Double
+                 , _sc_phyloSynchrony :: Double
+                 , _sc_phyloQuality   :: Double
+                 , _sc_timeUnit       :: TimeUnit
+                 , _sc_clique         :: Clique
+                 , _sc_exportFilter   :: Double
+                 }
+  deriving (Show,Generic,Eq)
+
+
+subConfig2config :: PhyloSubConfig -> PhyloConfig
+subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard $ _sc_phyloProximity subConfig
+                                           , phyloSynchrony = ByProximityThreshold (_sc_phyloSynchrony subConfig) 0 AllBranches MergeAllGroups
+                                           , phyloQuality   = Quality (_sc_phyloQuality   subConfig) 1
+                                           , timeUnit       = _sc_timeUnit       subConfig
+                                           , clique         = _sc_clique         subConfig
+                                           , exportFilter   = [ByBranchSize $ _sc_exportFilter   subConfig]
+                                           }
 
-defaultConfig :: Config
+------------------------------------------------------------------------
+defaultConfig :: PhyloConfig
 defaultConfig =
-     Config { corpusPath     = "corpus.csv" -- useful for commandline only
+     PhyloConfig { corpusPath     = "corpus.csv" -- useful for commandline only
             , listPath       = "list.csv"   -- useful for commandline only
             , outputPath     = "data/"
             , corpusParser   = Csv 100000
@@ -225,8 +244,15 @@ defaultConfig =
             , exportFilter   = [ByBranchSize 3]
             }
 
-instance FromJSON Config
-instance ToJSON Config
+-- Main Instances
+instance ToSchema PhyloConfig
+instance ToSchema PhyloSubConfig
+
+instance FromJSON PhyloConfig
+instance ToJSON PhyloConfig
+
+instance FromJSON PhyloSubConfig
+instance ToJSON PhyloSubConfig
 
 instance FromJSON CorpusParser
 instance ToJSON CorpusParser
@@ -298,7 +324,7 @@ defaultSoftware =
 data PhyloParam =
      PhyloParam { _phyloParam_version  :: Text
                 , _phyloParam_software :: Software
-                , _phyloParam_config   :: Config
+                , _phyloParam_config   :: PhyloConfig
      } deriving (Generic, Show, Eq)
 
 instance ToSchema PhyloParam where
@@ -564,7 +590,8 @@ instance ToSchema PhyloExport where
 -- | Lenses | --
 ----------------
 
-makeLenses ''Config
+makeLenses ''PhyloConfig
+makeLenses ''PhyloSubConfig
 makeLenses ''Proximity
 makeLenses ''SeaElevation
 makeLenses ''Quality

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -17,10 +17,6 @@ Portability : POSIX
 module Gargantext.Core.Viz.Phylo.API
   where
 
--- import Control.Lens ((^.))
--- import Gargantext.Core.Viz.Phylo.Example
--- import Gargantext.Database.Schema.Node (node_hyperdata)
---import Control.Monad.Reader (ask)
 import Data.Aeson
 import Data.Either
 import Data.Maybe (fromMaybe)
@@ -94,12 +90,17 @@ type GetPhylo =  QueryParam "listId"      ListId
 -- Fix Filter parameters
 -- TODO fix parameters to default config that should be in Node
 getPhylo :: PhyloId -> GargServer GetPhylo
-getPhylo phyloId _lId _level _minSizeBranch = do
+getPhylo phyloId _lId _level _minSizeBranch = getPhyloDataJson phyloId
+
+getPhyloDataJson :: PhyloId -> GargNoServer Value
+getPhyloDataJson phyloId = do
   maybePhyloData <- getPhyloData phyloId
   let phyloData = fromMaybe phyloExample maybePhyloData
   phyloJson <- liftBase $ phylo2dot2json phyloData
   pure phyloJson
 
+
+
 -- getPhylo phId _lId l msb  = do
   -- let
   --   level = fromMaybe 2 l

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -29,7 +29,7 @@ import Gargantext.API.Prelude (GargNoServer)
 import Gargantext.Core.Text.Context (TermList)
 import Gargantext.Core.Types (Context)
 import Gargantext.Core.Types.Main (ListType(MapTerm))
-import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), Config(..), Phylo)
+import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloStep)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
@@ -72,8 +72,8 @@ phylo2dot2json phylo = do
     file_to_json = "/tmp/toPhylo.json"
 
   _ <- dotToFile file_from (toPhyloExport phylo)
-  _ <- Shell.callProcess "/usr/bin/dot" ["-Tdot", "-o", file_dot, file_from]
-  _ <- Shell.callProcess "/usr/bin/dot" ["-Txdot_json", "-o", file_to_json, file_dot]
+  _ <- Shell.callProcess "dot" ["-Tdot", "-o", file_dot, file_from]
+  _ <- Shell.callProcess "dot" ["-Txdot_json", "-o", file_to_json, file_dot]
 
   maybeValue <- decodeFileStrict file_to_json
 
@@ -85,7 +85,7 @@ phylo2dot2json phylo = do
 
 
 
-flowPhyloAPI :: Config -> CorpusId -> GargNoServer Phylo
+flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
 flowPhyloAPI config cId = do
   (mapList, corpus) <- corpusIdtoDocuments (timeUnit config) cId
   phyloWithCliques <- pure $ toPhyloStep corpus mapList config
@@ -149,12 +149,10 @@ toMonths y m d = fromIntegral $ cdMonths
                $ diffGregorianDurationClip (fromGregorian y    m d)
                                            (fromGregorian 0000 0 0)
 
-
 toDays :: Integer -> Int -> Int -> Date
 toDays y m d = fromIntegral
              $ diffDays (fromGregorian y m d) (fromGregorian 0000 0 0)
 
-
 toPhyloDate :: Int -> Int -> Int -> TimeUnit -> Date
 toPhyloDate y m d tu = case tu of
   Year  _ _ _ -> y
@@ -192,5 +190,3 @@ readJson :: FilePath -> IO Lazy.ByteString
 readJson path = Lazy.readFile path
 
 
-
-

src/Gargantext/Core/Viz/Phylo/Example.hs

@@ -89,14 +89,16 @@ phyloCooc = docsToTimeScaleCooc docs (foundations ^. foundations_roots)
 
 
 periods :: [(Date,Date)]
-periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit config) (getTimeStep $ timeUnit config)
+periods = toPeriods (sort $ nub $ map date docs)
+                    (getTimePeriod $ timeUnit config)
+                    (getTimeStep $ timeUnit config)
 
 
 nbDocsByYear :: Map Date Double
 nbDocsByYear = docsToTimeScaleNb docs
 
 
-config :: Config
+config :: PhyloConfig
 config = 
     defaultConfig { phyloName  = "Cesar et Cleopatre"
                   , phyloLevel = 2
@@ -106,7 +108,7 @@ config =
 
 docs :: [Document]
 docs = map (\(d,t)
-    -> Document d
+    -> Document (d+102)
                 ""
                 (filter (\n -> isRoots n (foundations ^. foundations_roots)) $ monoTexts t) 
                 Nothing

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -45,7 +45,7 @@ data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
             | PhyloN    { _phylo'_phylo1    :: Phylo}
 
 
-toPhylo' :: Phylo' -> [Document] -> TermList -> Config -> Phylo
+toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
 toPhylo' (PhyloN    phylo) = toPhylo' 
 toPhylo' (PhyloBase phylo) = toPhylo 
 -}
@@ -160,7 +160,7 @@ indexDates' m = map (\docs ->
 
 -- To build the first phylo step from docs and terms
 -- QL: backend entre phyloBase et phyloClique
-toPhyloStep :: [Document] -> TermList -> Config -> Phylo
+toPhyloStep :: [Document] -> TermList -> PhyloConfig -> Phylo
 toPhyloStep docs lst conf = case (getSeaElevation phyloBase) of 
     Constante  _ _ -> appendGroups cliqueToGroup 1 phyloClique (updatePeriods (indexDates' docs') phyloBase)
     Adaptative _   -> toGroupsProxi 1 
@@ -362,7 +362,7 @@ initPhyloLevels lvlMax pId =
 
 
 --  To init the basic elements of a Phylo
-toPhyloBase :: [Document] -> TermList -> Config -> Phylo
+toPhyloBase :: [Document] -> TermList -> PhyloConfig -> Phylo
 toPhyloBase docs lst conf = 
     let foundations  = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst
         docsSources  = PhyloSources     (Vector.fromList $ nub $ concat $ map sources docs)

src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

@@ -400,11 +400,11 @@ getSeaElevation :: Phylo -> SeaElevation
 getSeaElevation phylo = seaElevation (getConfig phylo)
 
 
-getConfig :: Phylo -> Config
+getConfig :: Phylo -> PhyloConfig
 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
 
 
-setConfig :: Config -> Phylo -> Phylo
+setConfig :: PhyloConfig -> Phylo -> Phylo
 setConfig config phylo = phylo
                        & phylo_param .~ (PhyloParam
                                             ((phylo ^. phylo_param) ^. phyloParam_version)

src/Gargantext/Database/Action/Share.hs

@@ -27,7 +27,7 @@ import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 
--- | TODO move in Config of Gargantext
+-- | TODO move in PhyloConfig of Gargantext
 publicNodeTypes :: [NodeType]
 publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo, NodeFile]