Skip to content

haskell-gargantext
haskell-gargantext
Commit 8790c9de authored by qlobbe's avatar qlobbe
Browse files
Options

refactoring after code review #1

parent 5cc28172
Pipeline #3188 failed with stage
    in 71 minutes and 47 seconds
    Expand all Hide whitespace changes
    Inline Side-by-side
    Showing with 326 additions and 313 deletions
    bin/gargantext-phylo/Main.hs
    View file @ 8790c9de
    ......@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListType(..))
    import Gargantext.Core.Viz.Phylo
    import Gargantext.Core.Viz.Phylo.API.Tools
    import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
    import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloStep)
    import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
    import Gargantext.Core.Viz.Phylo.PhyloTools (printIOMsg, printIOComment, setConfig)
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
    import Gargantext.Database.Schema.Ngrams (NgramsType(..))
    ......@@ -50,7 +50,7 @@ import qualified Data.Text as T
    import qualified Data.Vector as Vector
    import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv
    data PhyloStage = PhyloWithCliques | PhyloWithLinks deriving (Show)
    data Backup = BackupPhyloWithoutLink | BackupPhylo deriving (Show)
    ---------------
    -- | Tools | --
    ......@@ -179,7 +179,7 @@ configToLabel :: PhyloConfig -> [Char]
    configToLabel config = outputPath config
    <> (unpack $ phyloName config)
    <> "-" <> (timeToLabel config)
    <> "-scale_" <> (show (phyloLevel config))
    <> "-scale_" <> (show (phyloScale config))
    <> "-" <> (seaToLabel config)
    <> "-" <> (sensToLabel config)
    <> "-" <> (cliqueToLabel config)
    ......@@ -189,18 +189,18 @@ configToLabel config = outputPath config
    -- To write a sha256 from a set of config's parameters
    configToSha :: PhyloStage -> PhyloConfig -> [Char]
    configToSha :: Backup -> PhyloConfig -> [Char]
    configToSha stage config = unpack
    $ replace "/" "-"
    $ T.pack (show (hash $ C8.pack label))
    where
    label :: [Char]
    label = case stage of
    PhyloWithCliques -> (corpusPath config)
    phyloWithoutLink -> (corpusPath config)
    <> (listPath config)
    <> (timeToLabel config)
    <> (cliqueToLabel config)
    PhyloWithLinks -> (corpusPath config)
    phylo -> (corpusPath config)
    <> (listPath config)
    <> (timeToLabel config)
    <> (cliqueToLabel config)
    ......@@ -208,7 +208,7 @@ configToSha stage config = unpack
    <> (seaToLabel config)
    <> (syncToLabel config)
    <> (qualToConfig config)
    <> (show (phyloLevel config))
    <> (show (phyloScale config))
    readListV4 :: [Char] -> IO NgramsList
    ......@@ -255,55 +255,38 @@ main = do
    printIOMsg "Reconstruct the phylo"
    let phyloWithCliquesFile = (outputPath config) <> "phyloWithCliques_" <> (configToSha PhyloWithCliques config) <> ".json"
    let phyloWithLinksFile = (outputPath config) <> "phyloWithLinks_" <> (configToSha PhyloWithLinks config) <> ".json"
    -- check the existing backup files
    phyloWithCliquesExists <- doesFileExist phyloWithCliquesFile
    phyloWithLinksExists <- doesFileExist phyloWithLinksFile
    let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
    let backupPhylo = (outputPath config) <> "backupPhylo_" <> (configToSha BackupPhylo config) <> ".json"
    -- phyloStep <- if phyloWithCliquesExists
    -- then do
    -- printIOMsg "Reconstruct the phylo step from an existing file"
    -- readPhylo phyloWithCliquesFile
    -- else do
    -- printIOMsg "Reconstruct the phylo step from scratch"
    -- pure $ toPhyloStep corpus mapList config
    phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
    phyloExists <- doesFileExist backupPhylo
    -- writePhylo phyloWithCliquesFile phyloStep
    -- reconstruct the phylo
    -- let phylo = toPhylo (setConfig config phyloStep)
    phylo <- if phyloExists
    then do
    printIOMsg "Reconstruct the phylo from an existing file"
    readPhylo backupPhylo
    else do
    if phyloWithoutLinkExists
    then do
    printIOMsg "Reconstruct the phylo from an existing file without links"
    phyloWithoutLink <- readPhylo backupPhyloWithoutLink
    writePhylo backupPhyloWithoutLink phyloWithoutLink
    pure $ toPhylo (setConfig config phyloWithoutLink)
    else do
    printIOMsg "Reconstruct the phylo from scratch"
    phyloWithoutLink <- pure $ toPhyloWithoutLink corpus mapList config
    writePhylo backupPhyloWithoutLink phyloWithoutLink
    pure $ toPhylo (setConfig config phyloWithoutLink)
    phyloWithLinks <- if phyloWithLinksExists
    then do
    printIOMsg "Reconstruct the phylo from an existing file with intertemporal links"
    readPhylo phyloWithLinksFile
    else do
    if phyloWithCliquesExists
    then do
    printIOMsg "Reconstruct the phylo from an existing file with cliques"
    phyloWithCliques <- readPhylo phyloWithCliquesFile
    writePhylo phyloWithCliquesFile phyloWithCliques
    pure $ toPhylo (setConfig config phyloWithCliques)
    else do
    printIOMsg "Reconstruct the phylo from scratch"
    phyloWithCliques <- pure $ toPhyloStep corpus mapList config
    writePhylo phyloWithCliquesFile phyloWithCliques
    pure $ toPhylo (setConfig config phyloWithCliques)
    writePhylo phyloWithLinksFile phyloWithLinks
    -- probes
    -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_synchronic_distance_cumu_jaccard.txt")
    -- $ synchronicDistance' phylo 1
    -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_inflexion_points.txt")
    -- $ inflexionPoints phylo 1
    writePhylo backupPhylo phylo
    printIOMsg "End of reconstruction, start the export"
    let dot = toPhyloExport (setConfig config phyloWithLinks)
    let dot = toPhyloExport (setConfig config phylo)
    let output = configToLabel config
    ......
    src/Gargantext/Core/Methods/Graph/MaxClique.hs
    View file @ 8790c9de
    ......@@ -72,7 +72,7 @@ type Neighbor = Node
    -- | getMaxCliques
    -- TODO chose distance order
    getMaxCliques :: Ord a => CliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
    getMaxCliques :: Ord a => MaxCliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
    getMaxCliques f d t m = map fromIndices $ getMaxCliques' t m'
    where
    m' = toIndex to m
    ......
    src/Gargantext/Core/Viz/Phylo.hs
    View file @ 8790c9de
    ......@@ -150,24 +150,24 @@ instance ToSchema TimeUnit where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    data CliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq)
    data MaxCliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq)
    instance ToSchema CliqueFilter where
    instance ToSchema MaxCliqueFilter where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    data Clique =
    data Cluster =
    Fis
    { _fis_support :: Int
    , _fis_size :: Int }
    | MaxClique
    { _mcl_size :: Int
    , _mcl_threshold :: Double
    , _mcl_filter :: CliqueFilter }
    , _mcl_filter :: MaxCliqueFilter }
    deriving (Show,Generic,Eq)
    instance ToSchema Clique where
    instance ToSchema Cluster where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    ......@@ -187,14 +187,14 @@ data PhyloConfig =
    , corpusParser :: CorpusParser
    , listParser :: ListParser
    , phyloName :: Text
    , phyloLevel :: Int
    , phyloScale :: Int
    , phyloProximity :: Proximity
    , seaElevation :: SeaElevation
    , findAncestors :: Bool
    , phyloSynchrony :: Synchrony
    , phyloQuality :: Quality
    , timeUnit :: TimeUnit
    , clique :: Clique
    , clique :: Cluster
    , exportLabel :: [PhyloLabel]
    , exportSort :: Sort
    , exportFilter :: [Filter]
    ......@@ -207,7 +207,7 @@ data PhyloSubConfig =
    , _sc_phyloSynchrony :: Double
    , _sc_phyloQuality :: Double
    , _sc_timeUnit :: TimeUnit
    , _sc_clique :: Clique
    , _sc_clique :: Cluster
    , _sc_exportFilter :: Double
    }
    deriving (Show,Generic,Eq)
    ......@@ -231,7 +231,7 @@ defaultConfig =
    , corpusParser = Csv 100000
    , listParser = V4
    , phyloName = pack "Phylo Name"
    , phyloLevel = 2
    , phyloScale = 2
    , phyloProximity = WeightedLogJaccard 0.5
    , seaElevation = Constante 0.1 0.1
    , findAncestors = False
    ......@@ -269,11 +269,11 @@ instance ToJSON SeaElevation
    instance FromJSON TimeUnit
    instance ToJSON TimeUnit
    instance FromJSON CliqueFilter
    instance ToJSON CliqueFilter
    instance FromJSON MaxCliqueFilter
    instance ToJSON MaxCliqueFilter
    instance FromJSON Clique
    instance ToJSON Clique
    instance FromJSON Cluster
    instance ToJSON Cluster
    instance FromJSON PhyloLabel
    instance ToJSON PhyloLabel
    ......@@ -346,6 +346,9 @@ defaultPhyloParam =
    -- | Date : a simple Integer
    type Date = Int
    -- | DateStr : the string version of a Date
    type DateStr = Text
    -- | Ngrams : a contiguous sequence of n terms
    type Ngrams = Text
    ......@@ -354,7 +357,7 @@ type Ngrams = Text
    -- Export Database to Document
    data Document = Document
    { date :: Date -- datatype Date {unDate :: Int}
    , date' :: Text -- show date
    , date' :: DateStr -- show date
    , text :: [Ngrams]
    , weight :: Maybe Double
    , sources :: [Text]
    ......@@ -396,6 +399,12 @@ type Cooc = Map (Int,Int) Double
    -- | Phylomemy | --
    -------------------
    -- | Period : a tuple of Dates
    type Period = (Date,Date)
    -- | PeriodStr : a tuple of DateStr
    type PeriodStr = (DateStr,DateStr)
    -- | Phylo datatype of a phylomemy
    -- foundations : the foundations of the phylo
    ......@@ -413,7 +422,8 @@ data Phylo =
    , _phylo_horizon :: !(Map (PhyloGroupId,PhyloGroupId) Double)
    , _phylo_groupsProxi :: !(Map (PhyloGroupId,PhyloGroupId) Double)
    , _phylo_param :: PhyloParam
    , _phylo_periods :: Map PhyloPeriodId PhyloPeriod
    , _phylo_periods :: Map Period PhyloPeriod
    , _phylo_quality :: Double
    }
    deriving (Generic, Show, Eq)
    ......@@ -421,57 +431,56 @@ instance ToSchema Phylo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    -- | PhyloPeriodId : the id of a given period
    type PhyloPeriodId = (Date,Date)
    ----------------
    -- | Period | --
    ----------------
    -- | PhyloPeriod : steps of a phylomemy on a temporal axis
    -- id: tuple (start date, end date) of the temporal step of the phylomemy
    -- levels: levels of granularity
    -- scales: scales of synchronic description
    data PhyloPeriod =
    PhyloPeriod { _phylo_periodPeriod :: (Date,Date)
    , _phylo_periodPeriod' :: (Text,Text)
    , _phylo_periodLevels :: Map PhyloLevelId PhyloLevel
    PhyloPeriod { _phylo_periodPeriod :: Period
    , _phylo_periodPeriodStr :: PeriodStr
    , _phylo_periodScales :: Map PhyloScaleId PhyloScale
    } deriving (Generic, Show, Eq)
    instance ToSchema PhyloPeriod where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    ---------------
    -- | Scale | --
    ---------------
    -- | Scale : a scale of synchronic description
    type Scale = Int
    -- | Level : a level of clustering
    type Level = Int
    -- | PhyloLevelId : the id of a level of clustering in a given period
    type PhyloLevelId = (PhyloPeriodId,Level)
    -- | PhyloScaleId : the id of a scale of synchronic description
    type PhyloScaleId = (Period,Scale)
    -- | PhyloLevel : levels of phylomemy on a synchronic axis
    -- Levels description:
    -- Level 0: The foundations and the base of the phylo
    -- Level 1: First level of clustering (the Fis)
    -- Level [2..N]: Nth level of synchronic clustering (cluster of Fis)
    data PhyloLevel =
    PhyloLevel { _phylo_levelPeriod :: (Date,Date)
    , _phylo_levelPeriod' :: (Text,Text)
    , _phylo_levelLevel :: Level
    , _phylo_levelGroups :: Map PhyloGroupId PhyloGroup
    -- | PhyloScale : sub-structure of the phylomemy in scale of synchronic description
    data PhyloScale =
    PhyloScale { _phylo_scalePeriod :: Period
    , _phylo_scalePeriodStr :: PeriodStr
    , _phylo_scaleScale :: Scale
    , _phylo_scaleGroups :: Map PhyloGroupId PhyloGroup
    }
    deriving (Generic, Show, Eq)
    instance ToSchema PhyloLevel where
    instance ToSchema PhyloScale where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    type PhyloGroupId = (PhyloLevelId, Int)
    type PhyloGroupId = (PhyloScaleId, Int)
    -- | BranchId : (a level, a sequence of branch index)
    -- | BranchId : (a scale, a sequence of branch index)
    -- the sequence is a path of heritage from the most to the less specific branch
    type PhyloBranchId = (Level, [Int])
    type PhyloBranchId = (Scale, [Int])
    -- | PhyloGroup : group of ngrams at each level and period
    -- | PhyloGroup : group of ngrams at each scale and period
    data PhyloGroup =
    PhyloGroup { _phylo_groupPeriod :: (Date,Date)
    PhyloGroup { _phylo_groupPeriod :: Period
    , _phylo_groupPeriod' :: (Text,Text)
    , _phylo_groupLevel :: Level
    , _phylo_groupScale :: Scale
    , _phylo_groupIndex :: Int
    , _phylo_groupLabel :: Text
    , _phylo_groupSupport :: Support
    ......@@ -481,8 +490,8 @@ data PhyloGroup =
    , _phylo_groupCooc :: !(Cooc)
    , _phylo_groupBranchId :: PhyloBranchId
    , _phylo_groupMeta :: Map Text [Double]
    , _phylo_groupLevelParents :: [Pointer]
    , _phylo_groupLevelChilds :: [Pointer]
    , _phylo_groupScaleParents :: [Pointer]
    , _phylo_groupScaleChilds :: [Pointer]
    , _phylo_groupPeriodParents :: [Pointer]
    , _phylo_groupPeriodChilds :: [Pointer]
    , _phylo_groupAncestors :: [Pointer]
    ......@@ -505,22 +514,23 @@ type Pointer = (PhyloGroupId, Weight)
    type Pointer' = (PhyloGroupId, (Thr,Weight))
    data Filiation = ToParents | ToChilds | ToParentsMemory | ToChildsMemory deriving (Generic, Show)
    data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)
    data PointerType = TemporalPointer | ScalePointer deriving (Generic, Show)
    ----------------------
    -- | Phylo Clique | --
    ----------------------
    --------------------------
    -- | Phylo Clustering | --
    --------------------------
    -- | Support : Number of Documents where a Clique occurs
    -- | Support : Number of Documents where a Cluster occurs
    type Support = Int
    data PhyloClique = PhyloClique
    { _phyloClique_nodes :: [Int]
    , _phyloClique_support :: Support
    , _phyloClique_period :: (Date,Date)
    , _phyloClique_weight :: Maybe Double
    , _phyloClique_sources :: [Int]
    data Clustering = Clustering
    { _clustering_roots :: [Int]
    , _clustering_support :: Support
    , _clustering_period :: Period
    -- additional materials for visualization
    , _clustering_visWeighting :: Maybe Double
    , _clustering_visFiltering :: [Int]
    } deriving (Generic,NFData,Show,Eq)
    ----------------
    ......@@ -595,14 +605,14 @@ makeLenses ''PhyloSubConfig
    makeLenses ''Proximity
    makeLenses ''SeaElevation
    makeLenses ''Quality
    makeLenses ''Clique
    makeLenses ''Cluster
    makeLenses ''PhyloLabel
    makeLenses ''TimeUnit
    makeLenses ''PhyloFoundations
    makeLenses ''PhyloClique
    makeLenses ''Clustering
    makeLenses ''Phylo
    makeLenses ''PhyloPeriod
    makeLenses ''PhyloLevel
    makeLenses ''PhyloScale
    makeLenses ''PhyloGroup
    makeLenses ''PhyloParam
    makeLenses ''PhyloExport
    ......@@ -624,8 +634,8 @@ instance ToJSON PhyloParam
    instance FromJSON PhyloPeriod
    instance ToJSON PhyloPeriod
    instance FromJSON PhyloLevel
    instance ToJSON PhyloLevel
    instance FromJSON PhyloScale
    instance ToJSON PhyloScale
    instance FromJSON Software
    instance ToJSON Software
    ......
    src/Gargantext/Core/Viz/Phylo/API.hs
    View file @ 8790c9de
    ......@@ -26,7 +26,7 @@ import Gargantext.Core.Types (TODO(..))
    import Gargantext.Core.Viz.LegacyPhylo
    import Gargantext.Core.Viz.Phylo (defaultConfig)
    import Gargantext.Core.Viz.Phylo.API.Tools
    import Gargantext.Core.Viz.Phylo.Example (phyloExample)
    import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
    import Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
    import Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
    ......@@ -99,7 +99,7 @@ getPhylo phyloId _lId _level _minSizeBranch = do
    getPhyloDataJson :: PhyloId -> GargNoServer Value
    getPhyloDataJson phyloId = do
    maybePhyloData <- getPhyloData phyloId
    let phyloData = fromMaybe phyloExample maybePhyloData
    let phyloData = fromMaybe phyloCleopatre maybePhyloData
    phyloJson <- liftBase $ phylo2dot2json phyloData
    pure phyloJson
    ......
    src/Gargantext/Core/Viz/Phylo/API/Tools.hs
    View file @ 8790c9de
    ......@@ -30,7 +30,7 @@ import Gargantext.Core.Types (Context)
    import Gargantext.Core.Types.Main (ListType(MapTerm))
    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.PhyloMaker (toPhylo, toPhyloWithoutLink)
    import Gargantext.Core.Viz.Phylo.PhyloTools ({-printIOMsg, printIOComment,-} setConfig)
    import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..))
    ......@@ -87,7 +87,7 @@ phylo2dot2json phylo = do
    flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
    flowPhyloAPI config cId = do
    (mapList, corpus) <- corpusIdtoDocuments (timeUnit config) cId
    phyloWithCliques <- pure $ toPhyloStep corpus mapList config
    phyloWithCliques <- pure $ toPhyloWithoutLink corpus mapList config
    -- writePhylo phyloWithCliquesFile phyloWithCliques
    pure $ toPhylo (setConfig config phyloWithCliques)
    ......
    src/Gargantext/Core/Viz/Phylo/Example.hs
    View file @ 8790c9de
    ......@@ -39,27 +39,27 @@ phyloExport :: IO ()
    phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot" phyloDot
    phyloDot :: DotGraph DotId
    phyloDot = toPhyloExport phyloExample
    phyloDot = toPhyloExport phyloCleopatre
    --------------------------------------------------
    -- | STEP 4 | -- Process the synchronic clustering
    --------------------------------------------------
    phyloExample :: Phylo
    phyloExample = synchronicClustering $ toHorizon phylo1
    phyloCleopatre :: Phylo
    phyloCleopatre = synchronicClustering $ toHorizon flatPhylo
    -----------------------------------------------
    -- | STEP 3 | -- Build the Level 1 of the Phylo
    -----------------------------------------------
    phylo1 :: Phylo
    phylo1 = case (getSeaElevation phyloBase) of
    flatPhylo :: Phylo
    flatPhylo = case (getSeaElevation emptyPhylo) of
    Constante s g -> constanteTemporalMatching s g
    $ toGroupsProxi 1
    $ appendGroups cliqueToGroup 1 phyloClique phyloBase
    $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
    Adaptative s -> adaptativeTemporalMatching s
    $ toGroupsProxi 1
    $ appendGroups cliqueToGroup 1 phyloClique phyloBase
    $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
    ---------------------------------------------
    ......@@ -67,21 +67,21 @@ phylo1 = case (getSeaElevation phyloBase) of
    ---------------------------------------------
    phyloClique :: Map (Date,Date) [PhyloClique]
    phyloClique = toPhyloClique phyloBase docsByPeriods
    seriesOfClustering :: Map (Date,Date) [Clustering]
    seriesOfClustering = toSeriesOfClustering emptyPhylo docsByPeriods
    docsByPeriods :: Map (Date,Date) [Document]
    docsByPeriods = groupDocsByPeriod date periods docs
    --------------------------------------------
    -- | STEP 1 | -- Init the Base of the Phylo
    --------------------------------------------
    ---------------------------------
    -- | STEP 1 | -- Init the Phylo
    ---------------------------------
    phyloBase :: Phylo
    phyloBase = toPhyloBase docs mapList config
    emptyPhylo :: Phylo
    emptyPhylo = initPhylo docs mapList config
    phyloCooc :: Map Date Cooc
    ......@@ -101,7 +101,7 @@ nbDocsByYear = docsToTimeScaleNb docs
    config :: PhyloConfig
    config =
    defaultConfig { phyloName = "Cesar et Cleopatre"
    , phyloLevel = 2
    , phyloScale = 2
    , exportFilter = [ByBranchSize 0]
    , clique = MaxClique 0 15 ByNeighbours }
    ......
    src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
    View file @ 8790c9de
    ......@@ -26,7 +26,7 @@ import Debug.Trace (trace)
    import Gargantext.Core.Viz.Phylo
    import Gargantext.Core.Viz.Phylo.PhyloTools
    import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toProximity, getNextPeriods)
    import Gargantext.Prelude
    import Gargantext.Prelude hiding (scale)
    import Prelude (writeFile)
    import System.FilePath
    import qualified Data.GraphViz.Attributes.HTML as H
    ......@@ -73,7 +73,7 @@ groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show
    branchIdToDotId :: PhyloBranchId -> DotId
    branchIdToDotId bId = (fromStrict . Text.pack) $ ("branch" <> show (snd bId))
    periodIdToDotId :: PhyloPeriodId -> DotId
    periodIdToDotId :: Period -> DotId
    periodIdToDotId prd = (fromStrict . Text.pack) $ ("period" <> show (fst prd) <> show (snd prd))
    groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label
    ......@@ -220,7 +220,8 @@ exportToDot phylo export =
    ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
    ,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo))
    ,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo)
    ,(toAttr (fromStrict "phyloLevel") $ pack $ show (_qua_granularity $ phyloQuality $ getConfig phylo))
    ,(toAttr (fromStrict "PhyloScale") $ pack $ show (_qua_granularity $ phyloQuality $ getConfig phylo))
    ,(toAttr (fromStrict "phyloQuality") $ pack $ show (phylo ^. phylo_quality))
    ,(toAttr (fromStrict "phyloSeaRiseStart") $ pack $ show (_cons_start $ getSeaElevation phylo))
    ,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (_cons_step $ getSeaElevation phylo))
    -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
    ......@@ -249,7 +250,7 @@ exportToDot phylo export =
    _ <- mapM (\period ->
    subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst $ _phylo_periodPeriod period) <> show (snd $ _phylo_periodPeriod period))) $ do
    graphAttrs [Rank SameRank]
    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriod')
    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriodStr)
    {-- 6) create a node for each group -}
    mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == (period ^. phylo_periodPeriod)) $ export ^. export_groups)
    ......@@ -615,28 +616,28 @@ headsToAncestors nbDocs diago proximity step heads acc =
    toHorizon :: Phylo -> Phylo
    toHorizon phylo =
    let phyloAncestor = updatePhyloGroups
    level
    scale
    (fromList $ map (\g -> (getGroupId g, g))
    $ concat
    $ tracePhyloAncestors newGroups) phylo
    reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat
    $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel level phyloAncestor
    in updatePhyloGroups level reBranched phylo
    $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel scale phyloAncestor
    in updatePhyloGroups scale reBranched phylo
    where
    -- | 1) for each periods
    periods :: [PhyloPeriodId]
    periods :: [Period]
    periods = getPeriodIds phylo
    -- --
    level :: Level
    level = getLastLevel phylo
    scale :: Scale
    scale = getLastLevel phylo
    -- --
    frame :: Int
    frame = getTimeFrame $ timeUnit $ getConfig phylo
    -- | 2) find ancestors between groups without parents
    mapGroups :: [[PhyloGroup]]
    mapGroups = map (\prd ->
    let groups = getGroupsFromLevelPeriods level [prd] phylo
    childs = getPreviousChildIds level frame prd periods phylo
    let groups = getGroupsFromLevelPeriods scale [prd] phylo
    childs = getPreviousChildIds scale frame prd periods phylo
    -- maybe add a better filter for non isolated ancestors
    heads = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds))
    $ filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups
    ......@@ -656,7 +657,7 @@ toHorizon phylo =
    newGroups = mapGroups `using` parList rdeepseq
    --------------------------------------
    getPreviousChildIds :: Level -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> Phylo -> [PhyloGroupId]
    getPreviousChildIds :: Scale -> Int -> Period -> [Period] -> Phylo -> [PhyloGroupId]
    getPreviousChildIds lvl frame curr prds phylo =
    concat $ map ((map fst) . _phylo_groupPeriodChilds)
    $ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo
    ......@@ -695,7 +696,7 @@ toPhyloExport phylo = exportToDot phylo
    groups :: [PhyloGroup]
    groups = traceExportGroups
    $ processDynamics
    $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
    $ getGroupsFromLevel (phyloScale $ getConfig phylo)
    $ tracePhyloInfo phylo
    -- \$ toHorizon phylo
    ......
    src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
    View file @ 8790c9de
    This diff is collapsed.
    src/Gargantext/Core/Viz/Phylo/PhyloTools.hs
    View file @ 8790c9de
    ......@@ -231,41 +231,41 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
    else f thr l
    traceClique :: Map (Date, Date) [PhyloClique] -> String
    traceClique :: Map (Date, Date) [Clustering] -> String
    traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
    where
    --------------------------------------
    cliques :: [Double]
    cliques = sort $ map (fromIntegral . length . _phyloClique_nodes) $ concat $ elems mFis
    cliques = sort $ map (fromIntegral . length . _clustering_roots) $ concat $ elems mFis
    --------------------------------------
    traceSupport :: Map (Date, Date) [PhyloClique] -> String
    traceSupport :: Map (Date, Date) [Clustering] -> String
    traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
    where
    --------------------------------------
    supports :: [Double]
    supports = sort $ map (fromIntegral . _phyloClique_support) $ concat $ elems mFis
    supports = sort $ map (fromIntegral . _clustering_support) $ concat $ elems mFis
    --------------------------------------
    traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
    traceFis :: [Char] -> Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
    traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
    <> "Support : " <> (traceSupport mFis) <> "\n"
    <> "Nb Ngrams : " <> (traceClique mFis) <> "\n" ) mFis
    ---------------
    -- | Clique| --
    ---------------
    ----------------
    -- | Cluster| --
    ----------------
    getCliqueSupport :: Clique -> Int
    getCliqueSupport :: Cluster -> Int
    getCliqueSupport unit = case unit of
    Fis s _ -> s
    MaxClique _ _ _ -> 0
    getCliqueSize :: Clique -> Int
    getCliqueSize :: Cluster -> Int
    getCliqueSize unit = case unit of
    Fis _ s -> s
    MaxClique s _ _ -> s
    ......@@ -315,9 +315,9 @@ ngramsToCooc ngrams coocs =
    --------------------
    getGroupId :: PhyloGroup -> PhyloGroupId
    getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupLevel), g ^. phylo_groupIndex)
    getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupScale), g ^. phylo_groupIndex)
    idToPrd :: PhyloGroupId -> PhyloPeriodId
    idToPrd :: PhyloGroupId -> Period
    idToPrd id = (fst . fst) id
    groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup]
    ......@@ -357,9 +357,9 @@ addPointers fil pty pointers g =
    ToParents -> g & phylo_groupPeriodParents .~ pointers
    ToChildsMemory -> undefined
    ToParentsMemory -> undefined
    LevelPointer -> case fil of
    ToChilds -> g & phylo_groupLevelChilds .~ pointers
    ToParents -> g & phylo_groupLevelParents .~ pointers
    ScalePointer -> case fil of
    ToChilds -> g & phylo_groupScaleChilds .~ pointers
    ToParents -> g & phylo_groupScaleParents .~ pointers
    ToChildsMemory -> undefined
    ToParentsMemory -> undefined
    ......@@ -375,7 +375,7 @@ addMemoryPointers fil pty thr pointers g =
    ToParents -> undefined
    ToChildsMemory -> g & phylo_groupPeriodMemoryChilds .~ (concat [(g ^. phylo_groupPeriodMemoryChilds),(map (\pt -> toPointer' thr pt) pointers)])
    ToParentsMemory -> g & phylo_groupPeriodMemoryParents .~ (concat [(g ^. phylo_groupPeriodMemoryParents),(map (\pt -> toPointer' thr pt) pointers)])
    LevelPointer -> undefined
    ScalePointer -> undefined
    getPeriodIds :: Phylo -> [(Date,Date)]
    ......@@ -384,17 +384,17 @@ getPeriodIds phylo = sortOn fst
    $ phylo ^. phylo_periods
    getLevelParentId :: PhyloGroup -> PhyloGroupId
    getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupLevelParents
    getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupScaleParents
    getLastLevel :: Phylo -> Level
    getLastLevel :: Phylo -> Scale
    getLastLevel phylo = last' "lastLevel" $ getLevels phylo
    getLevels :: Phylo -> [Level]
    getLevels :: Phylo -> [Scale]
    getLevels phylo = nub
    $ map snd
    $ keys $ view ( phylo_periods
    . traverse
    . phylo_periodLevels ) phylo
    . phylo_periodScales ) phylo
    getSeaElevation :: Phylo -> SeaElevation
    getSeaElevation phylo = seaElevation (getConfig phylo)
    ......@@ -426,44 +426,44 @@ phyloToLastBranches phylo = elems
    $ map (\g -> (g ^. phylo_groupBranchId, [g]))
    $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
    getGroupsFromLevel :: Level -> Phylo -> [PhyloGroup]
    getGroupsFromLevel :: Scale -> Phylo -> [PhyloGroup]
    getGroupsFromLevel lvl phylo =
    elems $ view ( phylo_periods
    . traverse
    . phylo_periodLevels
    . phylo_periodScales
    . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
    . phylo_levelGroups ) phylo
    . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_scaleGroups ) phylo
    getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
    getGroupsFromLevelPeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
    getGroupsFromLevelPeriods lvl periods phylo =
    elems $ view ( phylo_periods
    . traverse
    . filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
    . phylo_periodLevels
    . phylo_periodScales
    . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
    . phylo_levelGroups ) phylo
    . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_scaleGroups ) phylo
    getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
    getGroupsFromPeriods :: Scale -> Map Period PhyloPeriod -> [PhyloGroup]
    getGroupsFromPeriods lvl periods =
    elems $ view ( traverse
    . phylo_periodLevels
    . phylo_periodScales
    . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
    . phylo_levelGroups ) periods
    . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_scaleGroups ) periods
    updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
    updatePhyloGroups :: Scale -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
    updatePhyloGroups lvl m phylo =
    over ( phylo_periods
    . traverse
    . phylo_periodLevels
    . phylo_periodScales
    . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
    . phylo_levelGroups
    . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_scaleGroups
    . traverse
    ) (\g ->
    let id = getGroupId g
    ......@@ -477,13 +477,16 @@ updatePeriods periods' phylo =
    over (phylo_periods . traverse)
    (\prd ->
    let prd' = periods' ! (prd ^. phylo_periodPeriod)
    lvls = map (\lvl -> lvl & phylo_levelPeriod' .~ prd') $ prd ^. phylo_periodLevels
    in prd & phylo_periodPeriod' .~ prd'
    & phylo_periodLevels .~ lvls
    lvls = map (\lvl -> lvl & phylo_scalePeriodStr .~ prd') $ prd ^. phylo_periodScales
    in prd & phylo_periodPeriodStr .~ prd'
    & phylo_periodScales .~ lvls
    ) phylo
    updateQuality :: Double -> Phylo -> Phylo
    updateQuality quality phylo = phylo { _phylo_quality = quality }
    traceToPhylo :: Level -> Phylo -> Phylo
    traceToPhylo :: Scale -> Phylo -> Phylo
    traceToPhylo lvl phylo =
    trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
    <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
    ......@@ -516,8 +519,8 @@ mergeMeta bId groups =
    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
    groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches groups =
    groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches' groups =
    {- run the related component algorithm -}
    let egos = map (\g -> [getGroupId g]
    ++ (map fst $ g ^. phylo_groupPeriodParents)
    ......
    src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
    View file @ 8790c9de
    ......@@ -60,19 +60,19 @@ mergeGroups coocs id mapIds childs =
    mergeAncestors :: [Pointer] -> [Pointer]
    mergeAncestors pointers = Map.toList $ fromListWith max pointers
    addPhyloLevel :: Level -> Phylo -> Phylo
    addPhyloLevel lvl phylo =
    addPhyloScale :: Scale -> Phylo -> Phylo
    addPhyloScale lvl phylo =
    over ( phylo_periods . traverse )
    (\phyloPrd -> phyloPrd & phylo_periodLevels
    (\phyloPrd -> phyloPrd & phylo_periodScales
    %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl)
    (PhyloLevel (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriod') lvl empty))) phylo
    (PhyloScale (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriodStr) lvl empty))) phylo
    toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
    toNextLevel' phylo groups =
    toNextScale :: Phylo -> [PhyloGroup] -> Phylo
    toNextScale phylo groups =
    let curLvl = getLastLevel phylo
    oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
    newGroups = concat $ groupsToBranches
    newGroups = concat $ groupsToBranches'
    $ fromList $ map (\g -> (getGroupId g, g))
    $ foldlWithKey (\acc id groups' ->
    -- 4) create the parent group
    ......@@ -83,17 +83,17 @@ toNextLevel' phylo groups =
    newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups
    in traceSynchronyEnd
    $ over ( phylo_periods . traverse . phylo_periodLevels . traverse
    $ over ( phylo_periods . traverse . phylo_periodScales . traverse
    -- 6) update each period at curLvl + 1
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == (curLvl + 1)))
    . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == (curLvl + 1)))
    -- 7) by adding the parents
    (\phyloLvl ->
    if member (phyloLvl ^. phylo_levelPeriod) newPeriods
    then phyloLvl & phylo_levelGroups
    .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_levelPeriod))
    if member (phyloLvl ^. phylo_scalePeriod) newPeriods
    then phyloLvl & phylo_scaleGroups
    .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_scalePeriod))
    else phyloLvl)
    -- 2) add the curLvl + 1 phyloLevel to the phylo
    $ addPhyloLevel (curLvl + 1)
    -- 2) add the curLvl + 1 PhyloScale to the phylo
    $ addPhyloScale (curLvl + 1)
    -- 1) update the current groups (with level parent pointers) in the phylo
    $ updatePhyloGroups curLvl (fromList $ map (\g -> (getGroupId g, g)) groups) phylo
    ......@@ -150,7 +150,7 @@ groupsToEdges prox sync nbDocs diago groups =
    _ -> undefined
    toParentId :: PhyloGroup -> PhyloGroupId
    toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupLevel + 1), child ^. phylo_groupIndex)
    toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupScale + 1), child ^. phylo_groupIndex)
    reduceGroups :: Proximity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
    ......@@ -166,7 +166,7 @@ reduceGroups prox sync docs diagos branch =
    in map (\comp ->
    -- 4) add to each groups their futur level parent group
    let parentId = toParentId (head' "parentId" comp)
    in map (\g -> g & phylo_groupLevelParents %~ (++ [(parentId,1)]) ) comp )
    in map (\g -> g & phylo_groupScaleParents %~ (++ [(parentId,1)]) ) comp )
    -- 3) reduce the graph a a set of related components
    $ toRelatedComponents groups edges) periods
    ......@@ -185,7 +185,7 @@ adjustClustering sync branches = case sync of
    levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
    levelUpAncestors groups =
    -- 1) create an associative map of (old,new) ids
    let ids' = fromList $ map (\g -> (getGroupId g, fst $ head' "levelUpAncestors" ( g ^. phylo_groupLevelParents))) groups
    let ids' = fromList $ map (\g -> (getGroupId g, fst $ head' "levelUpAncestors" ( g ^. phylo_groupScaleParents))) groups
    in map (\g ->
    let id' = ids' ! (getGroupId g)
    ancestors = g ^. phylo_groupAncestors
    ......@@ -206,7 +206,7 @@ synchronicClustering phylo =
    $ phyloToLastBranches
    $ traceSynchronyStart phylo
    newBranches' = newBranches `using` parList rdeepseq
    in toNextLevel' phylo $ levelUpAncestors $ concat newBranches'
    in toNextScale phylo $ levelUpAncestors $ concat newBranches'
    -- synchronicDistance :: Phylo -> Level -> String
    ......
    Markdown is supported
    0% or
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment