[FEAT][PHYLO] update parameters with PhyloSubConfig

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

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/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 :: Proximity
+                 , _sc_phyloSynchrony :: Synchrony
+                 , _sc_phyloQuality   :: Quality
+                 , _sc_timeUnit       :: TimeUnit
+                 , _sc_clique         :: Clique
+                 , _sc_exportFilter   :: [Filter]
+                 }
+  deriving (Show,Generic,Eq)
+
+
+subConfig2config :: PhyloSubConfig -> PhyloConfig
+subConfig2config subConfig = defaultConfig { phyloProximity = _sc_phyloProximity subConfig
+                                           , phyloSynchrony = _sc_phyloSynchrony subConfig
+                                           , phyloQuality   = _sc_phyloQuality   subConfig
+                                           , timeUnit       = _sc_timeUnit       subConfig
+                                           , clique         = _sc_clique         subConfig
+                                           , exportFilter   = _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)

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)
@@ -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

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

@@ -96,7 +96,7 @@ nbDocsByYear :: Map Date Double
 nbDocsByYear = docsToTimeScaleNb docs
 
 
-config :: Config
+config :: PhyloConfig
 config = 
     defaultConfig { phyloName  = "Cesar et Cleopatre"
                   , phyloLevel = 2

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]