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
    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(..)) ...@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListType(..))
    import Gargantext.Core.Viz.Phylo import Gargantext.Core.Viz.Phylo
    import Gargantext.Core.Viz.Phylo.API.Tools import Gargantext.Core.Viz.Phylo.API.Tools
    import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile) 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.Core.Viz.Phylo.PhyloTools (printIOMsg, printIOComment, setConfig)
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..)) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
    import Gargantext.Database.Schema.Ngrams (NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
    ...@@ -50,7 +50,7 @@ import qualified Data.Text as T ...@@ -50,7 +50,7 @@ import qualified Data.Text as T
    import qualified Data.Vector as Vector import qualified Data.Vector as Vector
    import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv
    data PhyloStage = PhyloWithCliques | PhyloWithLinks deriving (Show) data Backup = BackupPhyloWithoutLink | BackupPhylo deriving (Show)
    --------------- ---------------
    -- | Tools | -- -- | Tools | --
    ...@@ -179,7 +179,7 @@ configToLabel :: PhyloConfig -> [Char] ...@@ -179,7 +179,7 @@ configToLabel :: PhyloConfig -> [Char]
    configToLabel config = outputPath config configToLabel config = outputPath config
    <> (unpack $ phyloName config) <> (unpack $ phyloName config)
    <> "-" <> (timeToLabel config) <> "-" <> (timeToLabel config)
    <> "-scale_" <> (show (phyloLevel config)) <> "-scale_" <> (show (phyloScale config))
    <> "-" <> (seaToLabel config) <> "-" <> (seaToLabel config)
    <> "-" <> (sensToLabel config) <> "-" <> (sensToLabel config)
    <> "-" <> (cliqueToLabel config) <> "-" <> (cliqueToLabel config)
    ...@@ -189,18 +189,18 @@ configToLabel config = outputPath config ...@@ -189,18 +189,18 @@ configToLabel config = outputPath config
    -- To write a sha256 from a set of config's parameters -- To write a sha256 from a set of config's parameters
    configToSha :: PhyloStage -> PhyloConfig -> [Char] configToSha :: Backup -> PhyloConfig -> [Char]
    configToSha stage config = unpack configToSha stage config = unpack
    $ replace "/" "-" $ replace "/" "-"
    $ T.pack (show (hash $ C8.pack label)) $ T.pack (show (hash $ C8.pack label))
    where where
    label :: [Char] label :: [Char]
    label = case stage of label = case stage of
    PhyloWithCliques -> (corpusPath config) phyloWithoutLink -> (corpusPath config)
    <> (listPath config) <> (listPath config)
    <> (timeToLabel config) <> (timeToLabel config)
    <> (cliqueToLabel config) <> (cliqueToLabel config)
    PhyloWithLinks -> (corpusPath config) phylo -> (corpusPath config)
    <> (listPath config) <> (listPath config)
    <> (timeToLabel config) <> (timeToLabel config)
    <> (cliqueToLabel config) <> (cliqueToLabel config)
    ...@@ -208,7 +208,7 @@ configToSha stage config = unpack ...@@ -208,7 +208,7 @@ configToSha stage config = unpack
    <> (seaToLabel config) <> (seaToLabel config)
    <> (syncToLabel config) <> (syncToLabel config)
    <> (qualToConfig config) <> (qualToConfig config)
    <> (show (phyloLevel config)) <> (show (phyloScale config))
    readListV4 :: [Char] -> IO NgramsList readListV4 :: [Char] -> IO NgramsList
    ...@@ -255,55 +255,38 @@ main = do ...@@ -255,55 +255,38 @@ main = do
    printIOMsg "Reconstruct the phylo" printIOMsg "Reconstruct the phylo"
    let phyloWithCliquesFile = (outputPath config) <> "phyloWithCliques_" <> (configToSha PhyloWithCliques config) <> ".json" -- check the existing backup files
    let phyloWithLinksFile = (outputPath config) <> "phyloWithLinks_" <> (configToSha PhyloWithLinks config) <> ".json"
    phyloWithCliquesExists <- doesFileExist phyloWithCliquesFile let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
    phyloWithLinksExists <- doesFileExist phyloWithLinksFile let backupPhylo = (outputPath config) <> "backupPhylo_" <> (configToSha BackupPhylo config) <> ".json"
    -- phyloStep <- if phyloWithCliquesExists phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
    -- then do phyloExists <- doesFileExist backupPhylo
    -- 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
    -- 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 writePhylo backupPhylo phylo
    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
    printIOMsg "End of reconstruction, start the export" printIOMsg "End of reconstruction, start the export"
    let dot = toPhyloExport (setConfig config phyloWithLinks) let dot = toPhyloExport (setConfig config phylo)
    let output = configToLabel config let output = configToLabel config
    ......
    src/Gargantext/Core/Methods/Graph/MaxClique.hs
    View file @ 8790c9de
    ...@@ -72,7 +72,7 @@ type Neighbor = Node ...@@ -72,7 +72,7 @@ type Neighbor = Node
    -- | getMaxCliques -- | getMaxCliques
    -- TODO chose distance order -- 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' getMaxCliques f d t m = map fromIndices $ getMaxCliques' t m'
    where where
    m' = toIndex to m m' = toIndex to m
    ......
    src/Gargantext/Core/Viz/Phylo.hs
    View file @ 8790c9de
    ...@@ -150,24 +150,24 @@ instance ToSchema TimeUnit where ...@@ -150,24 +150,24 @@ instance ToSchema TimeUnit where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") 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 "") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    data Clique = data Cluster =
    Fis Fis
    { _fis_support :: Int { _fis_support :: Int
    , _fis_size :: Int } , _fis_size :: Int }
    | MaxClique | MaxClique
    { _mcl_size :: Int { _mcl_size :: Int
    , _mcl_threshold :: Double , _mcl_threshold :: Double
    , _mcl_filter :: CliqueFilter } , _mcl_filter :: MaxCliqueFilter }
    deriving (Show,Generic,Eq) deriving (Show,Generic,Eq)
    instance ToSchema Clique where instance ToSchema Cluster where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
    ...@@ -187,14 +187,14 @@ data PhyloConfig = ...@@ -187,14 +187,14 @@ data PhyloConfig =
    , corpusParser :: CorpusParser , corpusParser :: CorpusParser
    , listParser :: ListParser , listParser :: ListParser
    , phyloName :: Text , phyloName :: Text
    , phyloLevel :: Int , phyloScale :: Int
    , phyloProximity :: Proximity , phyloProximity :: Proximity
    , seaElevation :: SeaElevation , seaElevation :: SeaElevation
    , findAncestors :: Bool , findAncestors :: Bool
    , phyloSynchrony :: Synchrony , phyloSynchrony :: Synchrony
    , phyloQuality :: Quality , phyloQuality :: Quality
    , timeUnit :: TimeUnit , timeUnit :: TimeUnit
    , clique :: Clique , clique :: Cluster
    , exportLabel :: [PhyloLabel] , exportLabel :: [PhyloLabel]
    , exportSort :: Sort , exportSort :: Sort
    , exportFilter :: [Filter] , exportFilter :: [Filter]
    ...@@ -207,7 +207,7 @@ data PhyloSubConfig = ...@@ -207,7 +207,7 @@ data PhyloSubConfig =
    , _sc_phyloSynchrony :: Double , _sc_phyloSynchrony :: Double
    , _sc_phyloQuality :: Double , _sc_phyloQuality :: Double
    , _sc_timeUnit :: TimeUnit , _sc_timeUnit :: TimeUnit
    , _sc_clique :: Clique , _sc_clique :: Cluster
    , _sc_exportFilter :: Double , _sc_exportFilter :: Double
    } }
    deriving (Show,Generic,Eq) deriving (Show,Generic,Eq)
    ...@@ -231,7 +231,7 @@ defaultConfig = ...@@ -231,7 +231,7 @@ defaultConfig =
    , corpusParser = Csv 100000 , corpusParser = Csv 100000
    , listParser = V4 , listParser = V4
    , phyloName = pack "Phylo Name" , phyloName = pack "Phylo Name"
    , phyloLevel = 2 , phyloScale = 2
    , phyloProximity = WeightedLogJaccard 0.5 , phyloProximity = WeightedLogJaccard 0.5
    , seaElevation = Constante 0.1 0.1 , seaElevation = Constante 0.1 0.1
    , findAncestors = False , findAncestors = False
    ...@@ -269,11 +269,11 @@ instance ToJSON SeaElevation ...@@ -269,11 +269,11 @@ instance ToJSON SeaElevation
    instance FromJSON TimeUnit instance FromJSON TimeUnit
    instance ToJSON TimeUnit instance ToJSON TimeUnit
    instance FromJSON CliqueFilter instance FromJSON MaxCliqueFilter
    instance ToJSON CliqueFilter instance ToJSON MaxCliqueFilter
    instance FromJSON Clique instance FromJSON Cluster
    instance ToJSON Clique instance ToJSON Cluster
    instance FromJSON PhyloLabel instance FromJSON PhyloLabel
    instance ToJSON PhyloLabel instance ToJSON PhyloLabel
    ...@@ -346,6 +346,9 @@ defaultPhyloParam = ...@@ -346,6 +346,9 @@ defaultPhyloParam =
    -- | Date : a simple Integer -- | Date : a simple Integer
    type Date = Int type Date = Int
    -- | DateStr : the string version of a Date
    type DateStr = Text
    -- | Ngrams : a contiguous sequence of n terms -- | Ngrams : a contiguous sequence of n terms
    type Ngrams = Text type Ngrams = Text
    ...@@ -354,7 +357,7 @@ type Ngrams = Text ...@@ -354,7 +357,7 @@ type Ngrams = Text
    -- Export Database to Document -- Export Database to Document
    data Document = Document data Document = Document
    { date :: Date -- datatype Date {unDate :: Int} { date :: Date -- datatype Date {unDate :: Int}
    , date' :: Text -- show date , date' :: DateStr -- show date
    , text :: [Ngrams] , text :: [Ngrams]
    , weight :: Maybe Double , weight :: Maybe Double
    , sources :: [Text] , sources :: [Text]
    ...@@ -396,6 +399,12 @@ type Cooc = Map (Int,Int) Double ...@@ -396,6 +399,12 @@ type Cooc = Map (Int,Int) Double
    -- | Phylomemy | -- -- | Phylomemy | --
    ------------------- -------------------
    -- | Period : a tuple of Dates
    type Period = (Date,Date)
    -- | PeriodStr : a tuple of DateStr
    type PeriodStr = (DateStr,DateStr)
    -- | Phylo datatype of a phylomemy -- | Phylo datatype of a phylomemy
    -- foundations : the foundations of the phylo -- foundations : the foundations of the phylo
    ...@@ -413,7 +422,8 @@ data Phylo = ...@@ -413,7 +422,8 @@ data Phylo =
    , _phylo_horizon :: !(Map (PhyloGroupId,PhyloGroupId) Double) , _phylo_horizon :: !(Map (PhyloGroupId,PhyloGroupId) Double)
    , _phylo_groupsProxi :: !(Map (PhyloGroupId,PhyloGroupId) Double) , _phylo_groupsProxi :: !(Map (PhyloGroupId,PhyloGroupId) Double)
    , _phylo_param :: PhyloParam , _phylo_param :: PhyloParam
    , _phylo_periods :: Map PhyloPeriodId PhyloPeriod , _phylo_periods :: Map Period PhyloPeriod
    , _phylo_quality :: Double
    } }
    deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
    ...@@ -421,57 +431,56 @@ instance ToSchema Phylo where ...@@ -421,57 +431,56 @@ instance ToSchema Phylo where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") 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 -- | PhyloPeriod : steps of a phylomemy on a temporal axis
    -- id: tuple (start date, end date) of the temporal step of the phylomemy -- id: tuple (start date, end date) of the temporal step of the phylomemy
    -- levels: levels of granularity -- scales: scales of synchronic description
    data PhyloPeriod = data PhyloPeriod =
    PhyloPeriod { _phylo_periodPeriod :: (Date,Date) PhyloPeriod { _phylo_periodPeriod :: Period
    , _phylo_periodPeriod' :: (Text,Text) , _phylo_periodPeriodStr :: PeriodStr
    , _phylo_periodLevels :: Map PhyloLevelId PhyloLevel , _phylo_periodScales :: Map PhyloScaleId PhyloScale
    } deriving (Generic, Show, Eq) } deriving (Generic, Show, Eq)
    instance ToSchema PhyloPeriod where instance ToSchema PhyloPeriod where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
    ---------------
    -- | Scale | --
    ---------------
    -- | Scale : a scale of synchronic description
    type Scale = Int
    -- | Level : a level of clustering -- | PhyloScaleId : the id of a scale of synchronic description
    type Level = Int type PhyloScaleId = (Period,Scale)
    -- | PhyloLevelId : the id of a level of clustering in a given period
    type PhyloLevelId = (PhyloPeriodId,Level)
    -- | PhyloLevel : levels of phylomemy on a synchronic axis -- | PhyloScale : sub-structure of the phylomemy in scale of synchronic description
    -- Levels description: data PhyloScale =
    -- Level 0: The foundations and the base of the phylo PhyloScale { _phylo_scalePeriod :: Period
    -- Level 1: First level of clustering (the Fis) , _phylo_scalePeriodStr :: PeriodStr
    -- Level [2..N]: Nth level of synchronic clustering (cluster of Fis) , _phylo_scaleScale :: Scale
    data PhyloLevel = , _phylo_scaleGroups :: Map PhyloGroupId PhyloGroup
    PhyloLevel { _phylo_levelPeriod :: (Date,Date)
    , _phylo_levelPeriod' :: (Text,Text)
    , _phylo_levelLevel :: Level
    , _phylo_levelGroups :: Map PhyloGroupId PhyloGroup
    } }
    deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
    instance ToSchema PhyloLevel where instance ToSchema PhyloScale where
    declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") 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 -- 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 = data PhyloGroup =
    PhyloGroup { _phylo_groupPeriod :: (Date,Date) PhyloGroup { _phylo_groupPeriod :: Period
    , _phylo_groupPeriod' :: (Text,Text) , _phylo_groupPeriod' :: (Text,Text)
    , _phylo_groupLevel :: Level , _phylo_groupScale :: Scale
    , _phylo_groupIndex :: Int , _phylo_groupIndex :: Int
    , _phylo_groupLabel :: Text , _phylo_groupLabel :: Text
    , _phylo_groupSupport :: Support , _phylo_groupSupport :: Support
    ...@@ -481,8 +490,8 @@ data PhyloGroup = ...@@ -481,8 +490,8 @@ data PhyloGroup =
    , _phylo_groupCooc :: !(Cooc) , _phylo_groupCooc :: !(Cooc)
    , _phylo_groupBranchId :: PhyloBranchId , _phylo_groupBranchId :: PhyloBranchId
    , _phylo_groupMeta :: Map Text [Double] , _phylo_groupMeta :: Map Text [Double]
    , _phylo_groupLevelParents :: [Pointer] , _phylo_groupScaleParents :: [Pointer]
    , _phylo_groupLevelChilds :: [Pointer] , _phylo_groupScaleChilds :: [Pointer]
    , _phylo_groupPeriodParents :: [Pointer] , _phylo_groupPeriodParents :: [Pointer]
    , _phylo_groupPeriodChilds :: [Pointer] , _phylo_groupPeriodChilds :: [Pointer]
    , _phylo_groupAncestors :: [Pointer] , _phylo_groupAncestors :: [Pointer]
    ...@@ -505,22 +514,23 @@ type Pointer = (PhyloGroupId, Weight) ...@@ -505,22 +514,23 @@ type Pointer = (PhyloGroupId, Weight)
    type Pointer' = (PhyloGroupId, (Thr,Weight)) type Pointer' = (PhyloGroupId, (Thr,Weight))
    data Filiation = ToParents | ToChilds | ToParentsMemory | ToChildsMemory deriving (Generic, Show) 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 type Support = Int
    data PhyloClique = PhyloClique data Clustering = Clustering
    { _phyloClique_nodes :: [Int] { _clustering_roots :: [Int]
    , _phyloClique_support :: Support , _clustering_support :: Support
    , _phyloClique_period :: (Date,Date) , _clustering_period :: Period
    , _phyloClique_weight :: Maybe Double -- additional materials for visualization
    , _phyloClique_sources :: [Int] , _clustering_visWeighting :: Maybe Double
    , _clustering_visFiltering :: [Int]
    } deriving (Generic,NFData,Show,Eq) } deriving (Generic,NFData,Show,Eq)
    ---------------- ----------------
    ...@@ -595,14 +605,14 @@ makeLenses ''PhyloSubConfig ...@@ -595,14 +605,14 @@ makeLenses ''PhyloSubConfig
    makeLenses ''Proximity makeLenses ''Proximity
    makeLenses ''SeaElevation makeLenses ''SeaElevation
    makeLenses ''Quality makeLenses ''Quality
    makeLenses ''Clique makeLenses ''Cluster
    makeLenses ''PhyloLabel makeLenses ''PhyloLabel
    makeLenses ''TimeUnit makeLenses ''TimeUnit
    makeLenses ''PhyloFoundations makeLenses ''PhyloFoundations
    makeLenses ''PhyloClique makeLenses ''Clustering
    makeLenses ''Phylo makeLenses ''Phylo
    makeLenses ''PhyloPeriod makeLenses ''PhyloPeriod
    makeLenses ''PhyloLevel makeLenses ''PhyloScale
    makeLenses ''PhyloGroup makeLenses ''PhyloGroup
    makeLenses ''PhyloParam makeLenses ''PhyloParam
    makeLenses ''PhyloExport makeLenses ''PhyloExport
    ...@@ -624,8 +634,8 @@ instance ToJSON PhyloParam ...@@ -624,8 +634,8 @@ instance ToJSON PhyloParam
    instance FromJSON PhyloPeriod instance FromJSON PhyloPeriod
    instance ToJSON PhyloPeriod instance ToJSON PhyloPeriod
    instance FromJSON PhyloLevel instance FromJSON PhyloScale
    instance ToJSON PhyloLevel instance ToJSON PhyloScale
    instance FromJSON Software instance FromJSON Software
    instance ToJSON Software instance ToJSON Software
    ......
    src/Gargantext/Core/Viz/Phylo/API.hs
    View file @ 8790c9de
    ...@@ -26,7 +26,7 @@ import Gargantext.Core.Types (TODO(..)) ...@@ -26,7 +26,7 @@ import Gargantext.Core.Types (TODO(..))
    import Gargantext.Core.Viz.LegacyPhylo import Gargantext.Core.Viz.LegacyPhylo
    import Gargantext.Core.Viz.Phylo (defaultConfig) import Gargantext.Core.Viz.Phylo (defaultConfig)
    import Gargantext.Core.Viz.Phylo.API.Tools 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.Core.Viz.Phylo.Legacy.LegacyMain
    import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..)) import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
    ...@@ -99,7 +99,7 @@ getPhylo phyloId _lId _level _minSizeBranch = do ...@@ -99,7 +99,7 @@ getPhylo phyloId _lId _level _minSizeBranch = do
    getPhyloDataJson :: PhyloId -> GargNoServer Value getPhyloDataJson :: PhyloId -> GargNoServer Value
    getPhyloDataJson phyloId = do getPhyloDataJson phyloId = do
    maybePhyloData <- getPhyloData phyloId maybePhyloData <- getPhyloData phyloId
    let phyloData = fromMaybe phyloExample maybePhyloData let phyloData = fromMaybe phyloCleopatre maybePhyloData
    phyloJson <- liftBase $ phylo2dot2json phyloData phyloJson <- liftBase $ phylo2dot2json phyloData
    pure phyloJson pure phyloJson
    ......
    src/Gargantext/Core/Viz/Phylo/API/Tools.hs
    View file @ 8790c9de
    ...@@ -30,7 +30,7 @@ import Gargantext.Core.Types (Context) ...@@ -30,7 +30,7 @@ import Gargantext.Core.Types (Context)
    import Gargantext.Core.Types.Main (ListType(MapTerm)) import Gargantext.Core.Types.Main (ListType(MapTerm))
    import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo) import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
    import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile) 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.Core.Viz.Phylo.PhyloTools ({-printIOMsg, printIOComment,-} setConfig)
    import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..)) import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
    import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..)) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..))
    ...@@ -87,7 +87,7 @@ phylo2dot2json phylo = do ...@@ -87,7 +87,7 @@ phylo2dot2json phylo = do
    flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
    flowPhyloAPI config cId = do flowPhyloAPI config cId = do
    (mapList, corpus) <- corpusIdtoDocuments (timeUnit config) cId (mapList, corpus) <- corpusIdtoDocuments (timeUnit config) cId
    phyloWithCliques <- pure $ toPhyloStep corpus mapList config phyloWithCliques <- pure $ toPhyloWithoutLink corpus mapList config
    -- writePhylo phyloWithCliquesFile phyloWithCliques -- writePhylo phyloWithCliquesFile phyloWithCliques
    pure $ toPhylo (setConfig config phyloWithCliques) pure $ toPhylo (setConfig config phyloWithCliques)
    ......
    src/Gargantext/Core/Viz/Phylo/Example.hs
    View file @ 8790c9de
    ...@@ -39,27 +39,27 @@ phyloExport :: IO () ...@@ -39,27 +39,27 @@ phyloExport :: IO ()
    phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot" phyloDot phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot" phyloDot
    phyloDot :: DotGraph DotId phyloDot :: DotGraph DotId
    phyloDot = toPhyloExport phyloExample phyloDot = toPhyloExport phyloCleopatre
    -------------------------------------------------- --------------------------------------------------
    -- | STEP 4 | -- Process the synchronic clustering -- | STEP 4 | -- Process the synchronic clustering
    -------------------------------------------------- --------------------------------------------------
    phyloExample :: Phylo phyloCleopatre :: Phylo
    phyloExample = synchronicClustering $ toHorizon phylo1 phyloCleopatre = synchronicClustering $ toHorizon flatPhylo
    ----------------------------------------------- -----------------------------------------------
    -- | STEP 3 | -- Build the Level 1 of the Phylo -- | STEP 3 | -- Build the Level 1 of the Phylo
    ----------------------------------------------- -----------------------------------------------
    phylo1 :: Phylo flatPhylo :: Phylo
    phylo1 = case (getSeaElevation phyloBase) of flatPhylo = case (getSeaElevation emptyPhylo) of
    Constante s g -> constanteTemporalMatching s g Constante s g -> constanteTemporalMatching s g
    $ toGroupsProxi 1 $ toGroupsProxi 1
    $ appendGroups cliqueToGroup 1 phyloClique phyloBase $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
    Adaptative s -> adaptativeTemporalMatching s Adaptative s -> adaptativeTemporalMatching s
    $ toGroupsProxi 1 $ toGroupsProxi 1
    $ appendGroups cliqueToGroup 1 phyloClique phyloBase $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
    --------------------------------------------- ---------------------------------------------
    ...@@ -67,21 +67,21 @@ phylo1 = case (getSeaElevation phyloBase) of ...@@ -67,21 +67,21 @@ phylo1 = case (getSeaElevation phyloBase) of
    --------------------------------------------- ---------------------------------------------
    phyloClique :: Map (Date,Date) [PhyloClique] seriesOfClustering :: Map (Date,Date) [Clustering]
    phyloClique = toPhyloClique phyloBase docsByPeriods seriesOfClustering = toSeriesOfClustering emptyPhylo docsByPeriods
    docsByPeriods :: Map (Date,Date) [Document] docsByPeriods :: Map (Date,Date) [Document]
    docsByPeriods = groupDocsByPeriod date periods docs docsByPeriods = groupDocsByPeriod date periods docs
    -------------------------------------------- ---------------------------------
    -- | STEP 1 | -- Init the Base of the Phylo -- | STEP 1 | -- Init the Phylo
    -------------------------------------------- ---------------------------------
    phyloBase :: Phylo emptyPhylo :: Phylo
    phyloBase = toPhyloBase docs mapList config emptyPhylo = initPhylo docs mapList config
    phyloCooc :: Map Date Cooc phyloCooc :: Map Date Cooc
    ...@@ -101,7 +101,7 @@ nbDocsByYear = docsToTimeScaleNb docs ...@@ -101,7 +101,7 @@ nbDocsByYear = docsToTimeScaleNb docs
    config :: PhyloConfig config :: PhyloConfig
    config = config =
    defaultConfig { phyloName = "Cesar et Cleopatre" defaultConfig { phyloName = "Cesar et Cleopatre"
    , phyloLevel = 2 , phyloScale = 2
    , exportFilter = [ByBranchSize 0] , exportFilter = [ByBranchSize 0]
    , clique = MaxClique 0 15 ByNeighbours } , clique = MaxClique 0 15 ByNeighbours }
    ......
    src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
    View file @ 8790c9de
    ...@@ -26,7 +26,7 @@ import Debug.Trace (trace) ...@@ -26,7 +26,7 @@ import Debug.Trace (trace)
    import Gargantext.Core.Viz.Phylo import Gargantext.Core.Viz.Phylo
    import Gargantext.Core.Viz.Phylo.PhyloTools import Gargantext.Core.Viz.Phylo.PhyloTools
    import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toProximity, getNextPeriods) import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toProximity, getNextPeriods)
    import Gargantext.Prelude import Gargantext.Prelude hiding (scale)
    import Prelude (writeFile) import Prelude (writeFile)
    import System.FilePath import System.FilePath
    import qualified Data.GraphViz.Attributes.HTML as H import qualified Data.GraphViz.Attributes.HTML as H
    ...@@ -73,7 +73,7 @@ groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show ...@@ -73,7 +73,7 @@ groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show
    branchIdToDotId :: PhyloBranchId -> DotId branchIdToDotId :: PhyloBranchId -> DotId
    branchIdToDotId bId = (fromStrict . Text.pack) $ ("branch" <> show (snd bId)) 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)) periodIdToDotId prd = (fromStrict . Text.pack) $ ("period" <> show (fst prd) <> show (snd prd))
    groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label
    ...@@ -220,7 +220,8 @@ exportToDot phylo export = ...@@ -220,7 +220,8 @@ exportToDot phylo export =
    ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups)) ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
    ,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo)) ,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo))
    ,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale 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 "phyloSeaRiseStart") $ pack $ show (_cons_start $ getSeaElevation phylo))
    ,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (_cons_step $ getSeaElevation phylo)) ,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (_cons_step $ getSeaElevation phylo))
    -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo)) -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
    ...@@ -249,7 +250,7 @@ exportToDot phylo export = ...@@ -249,7 +250,7 @@ exportToDot phylo export =
    _ <- mapM (\period -> _ <- mapM (\period ->
    subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst $ _phylo_periodPeriod period) <> show (snd $ _phylo_periodPeriod period))) $ do subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst $ _phylo_periodPeriod period) <> show (snd $ _phylo_periodPeriod period))) $ do
    graphAttrs [Rank SameRank] graphAttrs [Rank SameRank]
    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriod') periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriodStr)
    {-- 6) create a node for each group -} {-- 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) 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 = ...@@ -615,28 +616,28 @@ headsToAncestors nbDocs diago proximity step heads acc =
    toHorizon :: Phylo -> Phylo toHorizon :: Phylo -> Phylo
    toHorizon phylo = toHorizon phylo =
    let phyloAncestor = updatePhyloGroups let phyloAncestor = updatePhyloGroups
    level scale
    (fromList $ map (\g -> (getGroupId g, g)) (fromList $ map (\g -> (getGroupId g, g))
    $ concat $ concat
    $ tracePhyloAncestors newGroups) phylo $ tracePhyloAncestors newGroups) phylo
    reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat
    $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel level phyloAncestor $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel scale phyloAncestor
    in updatePhyloGroups level reBranched phylo in updatePhyloGroups scale reBranched phylo
    where where
    -- | 1) for each periods -- | 1) for each periods
    periods :: [PhyloPeriodId] periods :: [Period]
    periods = getPeriodIds phylo periods = getPeriodIds phylo
    -- -- -- --
    level :: Level scale :: Scale
    level = getLastLevel phylo scale = getLastLevel phylo
    -- -- -- --
    frame :: Int frame :: Int
    frame = getTimeFrame $ timeUnit $ getConfig phylo frame = getTimeFrame $ timeUnit $ getConfig phylo
    -- | 2) find ancestors between groups without parents -- | 2) find ancestors between groups without parents
    mapGroups :: [[PhyloGroup]] mapGroups :: [[PhyloGroup]]
    mapGroups = map (\prd -> mapGroups = map (\prd ->
    let groups = getGroupsFromLevelPeriods level [prd] phylo let groups = getGroupsFromLevelPeriods scale [prd] phylo
    childs = getPreviousChildIds level frame prd periods phylo childs = getPreviousChildIds scale frame prd periods phylo
    -- maybe add a better filter for non isolated ancestors -- maybe add a better filter for non isolated ancestors
    heads = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds)) heads = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds))
    $ filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups $ filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups
    ...@@ -656,7 +657,7 @@ toHorizon phylo = ...@@ -656,7 +657,7 @@ toHorizon phylo =
    newGroups = mapGroups `using` parList rdeepseq 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 = getPreviousChildIds lvl frame curr prds phylo =
    concat $ map ((map fst) . _phylo_groupPeriodChilds) concat $ map ((map fst) . _phylo_groupPeriodChilds)
    $ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo $ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo
    ...@@ -695,7 +696,7 @@ toPhyloExport phylo = exportToDot phylo ...@@ -695,7 +696,7 @@ toPhyloExport phylo = exportToDot phylo
    groups :: [PhyloGroup] groups :: [PhyloGroup]
    groups = traceExportGroups groups = traceExportGroups
    $ processDynamics $ processDynamics
    $ getGroupsFromLevel (phyloLevel $ getConfig phylo) $ getGroupsFromLevel (phyloScale $ getConfig phylo)
    $ tracePhyloInfo phylo $ tracePhyloInfo phylo
    -- \$ toHorizon phylo -- \$ toHorizon phylo
    ......
    src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs
    View file @ 8790c9de
    ...@@ -42,7 +42,7 @@ import qualified Data.Vector as Vector ...@@ -42,7 +42,7 @@ import qualified Data.Vector as Vector
    {- {-
    -- TODO AD -- TODO AD
    data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo} data Phylo' = PhyloBase { _phylo'_phyloBase :: Phylo}
    | PhyloN { _phylo'_phylo1 :: Phylo} | PhyloN { _phylo'_flatPhylo :: Phylo}
    toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo toPhylo' :: Phylo' -> [Document] -> TermList -> PhyloConfig -> Phylo
    ...@@ -50,23 +50,22 @@ toPhylo' (PhyloN phylo) = toPhylo' ...@@ -50,23 +50,22 @@ toPhylo' (PhyloN phylo) = toPhylo'
    toPhylo' (PhyloBase phylo) = toPhylo toPhylo' (PhyloBase phylo) = toPhylo
    -} -}
    toPhylo :: Phylo -> Phylo toPhylo :: Phylo -> Phylo
    toPhylo phyloStep = trace ("# phylo1 groups " <> show(length $ getGroupsFromLevel 1 phylo1)) toPhylo phylowithoutLink = trace ("# flatPhylo groups " <> show(length $ getGroupsFromLevel 1 flatPhylo))
    $ traceToPhylo (phyloLevel $ getConfig phyloStep) $ $ traceToPhylo (phyloScale $ getConfig phylowithoutLink) $
    if (phyloLevel $ getConfig phyloStep) > 1 if (phyloScale $ getConfig phylowithoutLink) > 1
    then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloLevel $ getConfig phyloStep)] then foldl' (\phylo' _ -> synchronicClustering phylo') phyloAncestors [2..(phyloScale $ getConfig phylowithoutLink)]
    else phylo1 else flatPhylo
    where where
    -------------------------------------- --------------------------------------
    phyloAncestors :: Phylo phyloAncestors :: Phylo
    phyloAncestors = phyloAncestors =
    if (findAncestors $ getConfig phyloStep) if (findAncestors $ getConfig phylowithoutLink)
    then toHorizon phylo1 then toHorizon flatPhylo
    else phylo1 else flatPhylo
    -------------------------------------- --------------------------------------
    phylo1 :: Phylo flatPhylo :: Phylo
    phylo1 = toPhylo1 phyloStep flatPhylo = addTemporalLinksToPhylo phylowithoutLink
    -------------------------------------- --------------------------------------
    ...@@ -74,16 +73,16 @@ toPhylo phyloStep = trace ("# phylo1 groups " <> show(length $ getGroupsFromLeve ...@@ -74,16 +73,16 @@ toPhylo phyloStep = trace ("# phylo1 groups " <> show(length $ getGroupsFromLeve
    -- | To Phylo 1 | -- -- | To Phylo 1 | --
    -------------------- --------------------
    toGroupsProxi :: Level -> Phylo -> Phylo toGroupsProxi :: Scale -> Phylo -> Phylo
    toGroupsProxi lvl phylo = toGroupsProxi lvl phylo =
    let proximity = phyloProximity $ getConfig phylo let proximity = phyloProximity $ getConfig phylo
    groupsProxi = foldlWithKey (\acc pId pds -> groupsProxi = foldlWithKey (\acc pId pds ->
    -- 1) process period by period -- 1) process period by period
    let egos = map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) let egos = map (\g -> (getGroupId g, g ^. phylo_groupNgrams))
    $ elems $ elems
    $ view ( phylo_periodLevels $ view ( phylo_periodScales
    . traverse . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl) . traverse . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_levelGroups ) pds . phylo_scaleGroups ) pds
    next = getNextPeriods ToParents (getTimeFrame $ timeUnit $ getConfig phylo) pId (keys $ phylo ^. phylo_periods) next = getNextPeriods ToParents (getTimeFrame $ timeUnit $ getConfig phylo) pId (keys $ phylo ^. phylo_periods)
    targets = map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ getGroupsFromLevelPeriods lvl next phylo targets = map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ getGroupsFromLevelPeriods lvl next phylo
    docs = filterDocs (phylo ^. phylo_timeDocs) ([pId] ++ next) docs = filterDocs (phylo ^. phylo_timeDocs) ([pId] ++ next)
    ...@@ -102,19 +101,19 @@ toGroupsProxi lvl phylo = ...@@ -102,19 +101,19 @@ toGroupsProxi lvl phylo =
    in phylo & phylo_groupsProxi .~ ((traceGroupsProxi . fromList) groupsProxi) in phylo & phylo_groupsProxi .~ ((traceGroupsProxi . fromList) groupsProxi)
    appendGroups :: (a -> PhyloPeriodId -> (Text,Text) -> Level -> Int -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo appendGroups :: (a -> Period -> (Text,Text) -> Scale -> Int -> [Cooc] -> PhyloGroup) -> Scale -> Map (Date,Date) [a] -> Phylo -> Phylo
    appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n") appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n")
    $ over ( phylo_periods $ over ( phylo_periods
    . traverse . traverse
    . phylo_periodLevels . phylo_periodScales
    . traverse) . traverse)
    (\phyloLvl -> if lvl == (phyloLvl ^. phylo_levelLevel) (\phyloLvl -> if lvl == (phyloLvl ^. phylo_scaleScale)
    then then
    let pId = phyloLvl ^. phylo_levelPeriod let pId = phyloLvl ^. phylo_scalePeriod
    pId' = phyloLvl ^. phylo_levelPeriod' pId' = phyloLvl ^. phylo_scalePeriodStr
    phyloCUnit = m ! pId phyloCUnit = m ! pId
    in phyloLvl in phyloLvl
    & phylo_levelGroups .~ (fromList $ foldl (\groups obj -> & phylo_scaleGroups .~ (fromList $ foldl (\groups obj ->
    groups ++ [ (((pId,lvl),length groups) groups ++ [ (((pId,lvl),length groups)
    , f obj pId pId' lvl (length groups) , f obj pId pId' lvl (length groups)
    (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId])) (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId]))
    ...@@ -124,22 +123,22 @@ appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ co ...@@ -124,22 +123,22 @@ appendGroups f lvl m phylo = trace ("\n" <> "-- | Append " <> show (length $ co
    phylo phylo
    cliqueToGroup :: PhyloClique -> PhyloPeriodId -> (Text,Text) -> Level -> Int -> [Cooc] -> PhyloGroup clusterToGroup :: Clustering -> Period -> (Text,Text) -> Scale -> Int -> [Cooc] -> PhyloGroup
    cliqueToGroup fis pId pId' lvl idx coocs = PhyloGroup pId pId' lvl idx "" clusterToGroup fis pId pId' lvl idx coocs = PhyloGroup pId pId' lvl idx ""
    (fis ^. phyloClique_support) (fis ^. clustering_support )
    (fis ^. phyloClique_weight) (fis ^. clustering_visWeighting)
    (fis ^. phyloClique_sources) (fis ^. clustering_visFiltering)
    (fis ^. phyloClique_nodes) (fis ^. clustering_roots)
    (ngramsToCooc (fis ^. phyloClique_nodes) coocs) (ngramsToCooc (fis ^. clustering_roots) coocs)
    (1,[0]) -- branchid (lvl,[path in the branching tree]) (1,[0]) -- branchid (lvl,[path in the branching tree])
    (fromList [("breaks",[0]),("seaLevels",[0])]) (fromList [("breaks",[0]),("seaLevels",[0])])
    [] [] [] [] [] [] [] [] [] [] [] [] [] []
    toPhylo1 :: Phylo -> Phylo addTemporalLinksToPhylo :: Phylo -> Phylo
    toPhylo1 phyloStep = case (getSeaElevation phyloStep) of addTemporalLinksToPhylo phylowithoutLink = case (getSeaElevation phylowithoutLink) of
    Constante start gap -> constanteTemporalMatching start gap phyloStep Constante start gap -> constanteTemporalMatching start gap phylowithoutLink
    Adaptative steps -> adaptativeTemporalMatching steps phyloStep Adaptative steps -> adaptativeTemporalMatching steps phylowithoutLink
    ----------------------- -----------------------
    -- | To Phylo Step | -- -- | To Phylo Step | --
    ...@@ -159,23 +158,24 @@ indexDates' m = map (\docs -> ...@@ -159,23 +158,24 @@ indexDates' m = map (\docs ->
    -- To build the first phylo step from docs and terms -- To build the first phylo step from docs and terms
    -- QL: backend entre phyloBase et phyloClique -- QL: backend entre phyloBase et Clustering
    toPhyloStep :: [Document] -> TermList -> PhyloConfig -> Phylo -- tophylowithoutLink
    toPhyloStep docs lst conf = case (getSeaElevation phyloBase) of toPhyloWithoutLink :: [Document] -> TermList -> PhyloConfig -> Phylo
    Constante _ _ -> appendGroups cliqueToGroup 1 phyloClique (updatePeriods (indexDates' docs') phyloBase) toPhyloWithoutLink docs lst conf = case (getSeaElevation phyloBase) of
    Constante _ _ -> appendGroups clusterToGroup 1 seriesOfClustering (updatePeriods (indexDates' docs') phyloBase)
    Adaptative _ -> toGroupsProxi 1 Adaptative _ -> toGroupsProxi 1
    $ appendGroups cliqueToGroup 1 phyloClique (updatePeriods (indexDates' docs') phyloBase) $ appendGroups clusterToGroup 1 seriesOfClustering (updatePeriods (indexDates' docs') phyloBase)
    where where
    -------------------------------------- --------------------------------------
    phyloClique :: Map (Date,Date) [PhyloClique] seriesOfClustering :: Map (Date,Date) [Clustering]
    phyloClique = toPhyloClique phyloBase docs' seriesOfClustering = toSeriesOfClustering phyloBase docs'
    -------------------------------------- --------------------------------------
    docs' :: Map (Date,Date) [Document] docs' :: Map (Date,Date) [Document]
    -- QL: Time Consuming here -- QL: Time Consuming here
    docs' = groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty docs' = groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
    -------------------------------------- --------------------------------------
    phyloBase :: Phylo phyloBase :: Phylo
    phyloBase = toPhyloBase docs lst conf phyloBase = initPhylo docs lst conf
    -------------------------------------- --------------------------------------
    --------------------------- ---------------------------
    ...@@ -184,30 +184,30 @@ toPhyloStep docs lst conf = case (getSeaElevation phyloBase) of ...@@ -184,30 +184,30 @@ toPhyloStep docs lst conf = case (getSeaElevation phyloBase) of
    -- To apply a filter with the possibility of keeping some periods non empty (keep : True|False) -- To apply a filter with the possibility of keeping some periods non empty (keep : True|False)
    filterClique :: Bool -> Int -> (Int -> [PhyloClique] -> [PhyloClique]) -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique] filterClique :: Bool -> Int -> (Int -> [Clustering] -> [Clustering]) -> Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
    filterClique keep thr f m = case keep of filterClique keep thr f m = case keep of
    False -> map (\l -> f thr l) m False -> map (\l -> f thr l) m
    True -> map (\l -> keepFilled (f) thr l) m True -> map (\l -> keepFilled (f) thr l) m
    -- To filter Fis with small Support -- To filter Fis with small Support
    filterCliqueBySupport :: Int -> [PhyloClique] -> [PhyloClique] filterCliqueBySupport :: Int -> [Clustering] -> [Clustering]
    filterCliqueBySupport thr l = filter (\clq -> (clq ^. phyloClique_support) >= thr) l filterCliqueBySupport thr l = filter (\clq -> (clq ^. clustering_support ) >= thr) l
    -- To filter Fis with small Clique size -- To filter Fis with small Clique size
    filterCliqueBySize :: Int -> [PhyloClique] -> [PhyloClique] filterCliqueBySize :: Int -> [Clustering] -> [Clustering]
    filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. phyloClique_nodes) >= thr) l filterCliqueBySize thr l = filter (\clq -> (length $ clq ^. clustering_roots) >= thr) l
    -- To filter nested Fis -- To filter nested Fis
    filterCliqueByNested :: Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique] filterCliqueByNested :: Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
    filterCliqueByNested m = filterCliqueByNested m =
    let clq = map (\l -> let clq = map (\l ->
    foldl (\mem f -> if (any (\f' -> isNested (f' ^. phyloClique_nodes) (f ^. phyloClique_nodes)) mem) foldl (\mem f -> if (any (\f' -> isNested (f' ^. clustering_roots) (f ^. clustering_roots)) mem)
    then mem then mem
    else else
    let fMax = filter (\f' -> not $ isNested (f ^. phyloClique_nodes) (f' ^. phyloClique_nodes)) mem let fMax = filter (\f' -> not $ isNested (f ^. clustering_roots) (f' ^. clustering_roots)) mem
    in fMax ++ [f] ) [] l) in fMax ++ [f] ) [] l)
    $ elems m $ elems m
    clq' = clq `using` parList rdeepseq clq' = clq `using` parList rdeepseq
    ...@@ -215,8 +215,8 @@ filterCliqueByNested m = ...@@ -215,8 +215,8 @@ filterCliqueByNested m =
    -- | To transform a time map of docs into a time map of Fis with some filters -- | To transform a time map of docs into a time map of Fis with some filters
    toPhyloClique :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [PhyloClique] toSeriesOfClustering :: Phylo -> Map (Date, Date) [Document] -> Map (Date,Date) [Clustering]
    toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of toSeriesOfClustering phylo phyloDocs = case (clique $ getConfig phylo) of
    Fis s s' -> -- traceFis "Filtered Fis" Fis s s' -> -- traceFis "Filtered Fis"
    filterCliqueByNested filterCliqueByNested
    {- \$ traceFis "Filtered by clique size" -} {- \$ traceFis "Filtered by clique size" -}
    ...@@ -224,22 +224,22 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of ...@@ -224,22 +224,22 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
    {- \$ traceFis "Filtered by support" -} {- \$ traceFis "Filtered by support" -}
    $ filterClique True s (filterCliqueBySupport) $ filterClique True s (filterCliqueBySupport)
    {- \$ traceFis "Unfiltered Fis" -} {- \$ traceFis "Unfiltered Fis" -}
    phyloClique seriesOfClustering
    MaxClique s _ _ -> filterClique True s (filterCliqueBySize) MaxClique s _ _ -> filterClique True s (filterCliqueBySize)
    phyloClique seriesOfClustering
    where where
    -------------------------------------- --------------------------------------
    phyloClique :: Map (Date,Date) [PhyloClique] seriesOfClustering :: Map (Date,Date) [Clustering]
    phyloClique = case (clique $ getConfig phylo) of seriesOfClustering = case (clique $ getConfig phylo) of
    Fis _ _ -> Fis _ _ ->
    let fis = map (\(prd,docs) -> let fis = map (\(prd,docs) ->
    case (corpusParser $ getConfig phylo) of case (corpusParser $ getConfig phylo) of
    Csv' _ -> let lst = toList Csv' _ -> let lst = toList
    $ fisWithSizePolyMap' (Segment 1 20) 1 (map (\d -> (ngramsToIdx (text d) (getRoots phylo), (weight d, (sourcesToIdx (sources d) (getSources phylo))))) docs) $ fisWithSizePolyMap' (Segment 1 20) 1 (map (\d -> (ngramsToIdx (text d) (getRoots phylo), (weight d, (sourcesToIdx (sources d) (getSources phylo))))) docs)
    in (prd, map (\f -> PhyloClique (Set.toList $ fst f) ((fst . snd) f) prd ((fst . snd . snd) f) (((snd . snd . snd) f))) lst) in (prd, map (\f -> Clustering (Set.toList $ fst f) ((fst . snd) f) prd ((fst . snd . snd) f) (((snd . snd . snd) f))) lst)
    _ -> let lst = toList _ -> let lst = toList
    $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs) $ fisWithSizePolyMap (Segment 1 20) 1 (map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs)
    in (prd, map (\f -> PhyloClique (Set.toList $ fst f) (snd f) prd (Just $ fromIntegral $ snd f) []) lst) in (prd, map (\f -> Clustering (Set.toList $ fst f) (snd f) prd (Just $ fromIntegral $ snd f) []) lst)
    ) )
    $ toList phyloDocs $ toList phyloDocs
    fis' = fis `using` parList rdeepseq fis' = fis `using` parList rdeepseq
    ...@@ -250,7 +250,7 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of ...@@ -250,7 +250,7 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
    $ foldl sumCooc empty $ foldl sumCooc empty
    $ map listToMatrix $ map listToMatrix
    $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
    in (prd, map (\cl -> PhyloClique cl 0 prd Nothing []) $ getMaxCliques filterType Conditional thr cooc)) in (prd, map (\cl -> Clustering cl 0 prd Nothing []) $ getMaxCliques filterType Conditional thr cooc))
    $ toList phyloDocs $ toList phyloDocs
    mcl' = mcl `using` parList rdeepseq mcl' = mcl `using` parList rdeepseq
    in fromList mcl' in fromList mcl'
    ...@@ -355,20 +355,21 @@ docsToTimeScaleNb docs = ...@@ -355,20 +355,21 @@ docsToTimeScaleNb docs =
    $ unionWith (+) time docs' $ unionWith (+) time docs'
    initPhyloLevels :: Int -> PhyloPeriodId -> Map PhyloLevelId PhyloLevel initPhyloScales :: Int -> Period -> Map PhyloScaleId PhyloScale
    initPhyloLevels lvlMax pId = initPhyloScales lvlMax pId =
    fromList $ map (\lvl -> ((pId,lvl),PhyloLevel pId ("","") lvl empty)) [1..lvlMax] fromList $ map (\lvl -> ((pId,lvl),PhyloScale pId ("","") lvl empty)) [1..lvlMax]
    -- To init the basic elements of a Phylo -- Init the basic elements of a Phylo
    toPhyloBase :: [Document] -> TermList -> PhyloConfig -> Phylo --
    toPhyloBase docs lst conf = initPhylo :: [Document] -> TermList -> PhyloConfig -> Phylo
    initPhylo docs lst conf =
    let foundations = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst let foundations = PhyloFoundations (Vector.fromList $ nub $ concat $ map text docs) lst
    docsSources = PhyloSources (Vector.fromList $ nub $ concat $ map sources docs) docsSources = PhyloSources (Vector.fromList $ nub $ concat $ map sources docs)
    params = defaultPhyloParam { _phyloParam_config = conf } params = defaultPhyloParam { _phyloParam_config = conf }
    periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit conf) (getTimeStep $ timeUnit conf) periods = toPeriods (sort $ nub $ map date docs) (getTimePeriod $ timeUnit conf) (getTimeStep $ timeUnit conf)
    in trace ("\n" <> "-- | Create PhyloBase out of " <> show(length docs) <> " docs \n") in trace ("\n" <> "-- | Init a phylo out of " <> show(length docs) <> " docs \n")
    $ Phylo foundations $ Phylo foundations
    docsSources docsSources
    (docsToTimeScaleCooc docs (foundations ^. foundations_roots)) (docsToTimeScaleCooc docs (foundations ^. foundations_roots))
    ...@@ -378,4 +379,5 @@ toPhyloBase docs lst conf = ...@@ -378,4 +379,5 @@ toPhyloBase docs lst conf =
    empty empty
    empty empty
    params params
    (fromList $ map (\prd -> (prd, PhyloPeriod prd ("","") (initPhyloLevels 1 prd))) periods) (fromList $ map (\prd -> (prd, PhyloPeriod prd ("","") (initPhyloScales 1 prd))) periods)
    0
    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) ...@@ -231,41 +231,41 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
    else f thr 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] traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
    where where
    -------------------------------------- --------------------------------------
    cliques :: [Double] 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] traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") " ) "" [1..6]
    where where
    -------------------------------------- --------------------------------------
    supports :: [Double] 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" traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
    <> "Support : " <> (traceSupport mFis) <> "\n" <> "Support : " <> (traceSupport mFis) <> "\n"
    <> "Nb Ngrams : " <> (traceClique mFis) <> "\n" ) mFis <> "Nb Ngrams : " <> (traceClique mFis) <> "\n" ) mFis
    --------------- ----------------
    -- | Clique| -- -- | Cluster| --
    --------------- ----------------
    getCliqueSupport :: Clique -> Int getCliqueSupport :: Cluster -> Int
    getCliqueSupport unit = case unit of getCliqueSupport unit = case unit of
    Fis s _ -> s Fis s _ -> s
    MaxClique _ _ _ -> 0 MaxClique _ _ _ -> 0
    getCliqueSize :: Clique -> Int getCliqueSize :: Cluster -> Int
    getCliqueSize unit = case unit of getCliqueSize unit = case unit of
    Fis _ s -> s Fis _ s -> s
    MaxClique s _ _ -> s MaxClique s _ _ -> s
    ...@@ -315,9 +315,9 @@ ngramsToCooc ngrams coocs = ...@@ -315,9 +315,9 @@ ngramsToCooc ngrams coocs =
    -------------------- --------------------
    getGroupId :: PhyloGroup -> PhyloGroupId 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 idToPrd id = (fst . fst) id
    groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup] groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup]
    ...@@ -357,9 +357,9 @@ addPointers fil pty pointers g = ...@@ -357,9 +357,9 @@ addPointers fil pty pointers g =
    ToParents -> g & phylo_groupPeriodParents .~ pointers ToParents -> g & phylo_groupPeriodParents .~ pointers
    ToChildsMemory -> undefined ToChildsMemory -> undefined
    ToParentsMemory -> undefined ToParentsMemory -> undefined
    LevelPointer -> case fil of ScalePointer -> case fil of
    ToChilds -> g & phylo_groupLevelChilds .~ pointers ToChilds -> g & phylo_groupScaleChilds .~ pointers
    ToParents -> g & phylo_groupLevelParents .~ pointers ToParents -> g & phylo_groupScaleParents .~ pointers
    ToChildsMemory -> undefined ToChildsMemory -> undefined
    ToParentsMemory -> undefined ToParentsMemory -> undefined
    ...@@ -375,7 +375,7 @@ addMemoryPointers fil pty thr pointers g = ...@@ -375,7 +375,7 @@ addMemoryPointers fil pty thr pointers g =
    ToParents -> undefined ToParents -> undefined
    ToChildsMemory -> g & phylo_groupPeriodMemoryChilds .~ (concat [(g ^. phylo_groupPeriodMemoryChilds),(map (\pt -> toPointer' thr pt) pointers)]) 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)]) ToParentsMemory -> g & phylo_groupPeriodMemoryParents .~ (concat [(g ^. phylo_groupPeriodMemoryParents),(map (\pt -> toPointer' thr pt) pointers)])
    LevelPointer -> undefined ScalePointer -> undefined
    getPeriodIds :: Phylo -> [(Date,Date)] getPeriodIds :: Phylo -> [(Date,Date)]
    ...@@ -384,17 +384,17 @@ getPeriodIds phylo = sortOn fst ...@@ -384,17 +384,17 @@ getPeriodIds phylo = sortOn fst
    $ phylo ^. phylo_periods $ phylo ^. phylo_periods
    getLevelParentId :: PhyloGroup -> PhyloGroupId 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 getLastLevel phylo = last' "lastLevel" $ getLevels phylo
    getLevels :: Phylo -> [Level] getLevels :: Phylo -> [Scale]
    getLevels phylo = nub getLevels phylo = nub
    $ map snd $ map snd
    $ keys $ view ( phylo_periods $ keys $ view ( phylo_periods
    . traverse . traverse
    . phylo_periodLevels ) phylo . phylo_periodScales ) phylo
    getSeaElevation :: Phylo -> SeaElevation getSeaElevation :: Phylo -> SeaElevation
    getSeaElevation phylo = seaElevation (getConfig phylo) getSeaElevation phylo = seaElevation (getConfig phylo)
    ...@@ -426,44 +426,44 @@ phyloToLastBranches phylo = elems ...@@ -426,44 +426,44 @@ phyloToLastBranches phylo = elems
    $ map (\g -> (g ^. phylo_groupBranchId, [g])) $ map (\g -> (g ^. phylo_groupBranchId, [g]))
    $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
    getGroupsFromLevel :: Level -> Phylo -> [PhyloGroup] getGroupsFromLevel :: Scale -> Phylo -> [PhyloGroup]
    getGroupsFromLevel lvl phylo = getGroupsFromLevel lvl phylo =
    elems $ view ( phylo_periods elems $ view ( phylo_periods
    . traverse . traverse
    . phylo_periodLevels . phylo_periodScales
    . traverse . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl) . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_levelGroups ) phylo . phylo_scaleGroups ) phylo
    getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup] getGroupsFromLevelPeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
    getGroupsFromLevelPeriods lvl periods phylo = getGroupsFromLevelPeriods lvl periods phylo =
    elems $ view ( phylo_periods elems $ view ( phylo_periods
    . traverse . traverse
    . filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods) . filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
    . phylo_periodLevels . phylo_periodScales
    . traverse . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl) . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_levelGroups ) phylo . phylo_scaleGroups ) phylo
    getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup] getGroupsFromPeriods :: Scale -> Map Period PhyloPeriod -> [PhyloGroup]
    getGroupsFromPeriods lvl periods = getGroupsFromPeriods lvl periods =
    elems $ view ( traverse elems $ view ( traverse
    . phylo_periodLevels . phylo_periodScales
    . traverse . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl) . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_levelGroups ) periods . phylo_scaleGroups ) periods
    updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo updatePhyloGroups :: Scale -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
    updatePhyloGroups lvl m phylo = updatePhyloGroups lvl m phylo =
    over ( phylo_periods over ( phylo_periods
    . traverse . traverse
    . phylo_periodLevels . phylo_periodScales
    . traverse . traverse
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl) . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
    . phylo_levelGroups . phylo_scaleGroups
    . traverse . traverse
    ) (\g -> ) (\g ->
    let id = getGroupId g let id = getGroupId g
    ...@@ -477,13 +477,16 @@ updatePeriods periods' phylo = ...@@ -477,13 +477,16 @@ updatePeriods periods' phylo =
    over (phylo_periods . traverse) over (phylo_periods . traverse)
    (\prd -> (\prd ->
    let prd' = periods' ! (prd ^. phylo_periodPeriod) let prd' = periods' ! (prd ^. phylo_periodPeriod)
    lvls = map (\lvl -> lvl & phylo_levelPeriod' .~ prd') $ prd ^. phylo_periodLevels lvls = map (\lvl -> lvl & phylo_scalePeriodStr .~ prd') $ prd ^. phylo_periodScales
    in prd & phylo_periodPeriod' .~ prd' in prd & phylo_periodPeriodStr .~ prd'
    & phylo_periodLevels .~ lvls & phylo_periodScales .~ lvls
    ) phylo ) phylo
    updateQuality :: Double -> Phylo -> Phylo
    updateQuality quality phylo = phylo { _phylo_quality = quality }
    traceToPhylo :: Level -> Phylo -> Phylo traceToPhylo :: Scale -> Phylo -> Phylo
    traceToPhylo lvl phylo = traceToPhylo lvl phylo =
    trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with " trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
    <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and " <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
    ...@@ -516,8 +519,8 @@ mergeMeta bId groups = ...@@ -516,8 +519,8 @@ mergeMeta bId groups =
    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")] in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
    groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]] groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches groups = groupsToBranches' groups =
    {- run the related component algorithm -} {- run the related component algorithm -}
    let egos = map (\g -> [getGroupId g] let egos = map (\g -> [getGroupId g]
    ++ (map fst $ g ^. phylo_groupPeriodParents) ++ (map fst $ g ^. phylo_groupPeriodParents)
    ......
    src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs
    View file @ 8790c9de
    ...@@ -60,19 +60,19 @@ mergeGroups coocs id mapIds childs = ...@@ -60,19 +60,19 @@ mergeGroups coocs id mapIds childs =
    mergeAncestors :: [Pointer] -> [Pointer] mergeAncestors :: [Pointer] -> [Pointer]
    mergeAncestors pointers = Map.toList $ fromListWith max pointers mergeAncestors pointers = Map.toList $ fromListWith max pointers
    addPhyloLevel :: Level -> Phylo -> Phylo addPhyloScale :: Scale -> Phylo -> Phylo
    addPhyloLevel lvl phylo = addPhyloScale lvl phylo =
    over ( phylo_periods . traverse ) over ( phylo_periods . traverse )
    (\phyloPrd -> phyloPrd & phylo_periodLevels (\phyloPrd -> phyloPrd & phylo_periodScales
    %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) %~ (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 toNextScale :: Phylo -> [PhyloGroup] -> Phylo
    toNextLevel' phylo groups = toNextScale phylo groups =
    let curLvl = getLastLevel phylo let curLvl = getLastLevel phylo
    oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
    newGroups = concat $ groupsToBranches newGroups = concat $ groupsToBranches'
    $ fromList $ map (\g -> (getGroupId g, g)) $ fromList $ map (\g -> (getGroupId g, g))
    $ foldlWithKey (\acc id groups' -> $ foldlWithKey (\acc id groups' ->
    -- 4) create the parent group -- 4) create the parent group
    ...@@ -83,17 +83,17 @@ toNextLevel' phylo groups = ...@@ -83,17 +83,17 @@ toNextLevel' phylo groups =
    newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups
    in traceSynchronyEnd in traceSynchronyEnd
    $ over ( phylo_periods . traverse . phylo_periodLevels . traverse $ over ( phylo_periods . traverse . phylo_periodScales . traverse
    -- 6) update each period at curLvl + 1 -- 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 -- 7) by adding the parents
    (\phyloLvl -> (\phyloLvl ->
    if member (phyloLvl ^. phylo_levelPeriod) newPeriods if member (phyloLvl ^. phylo_scalePeriod) newPeriods
    then phyloLvl & phylo_levelGroups then phyloLvl & phylo_scaleGroups
    .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_levelPeriod)) .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_scalePeriod))
    else phyloLvl) else phyloLvl)
    -- 2) add the curLvl + 1 phyloLevel to the phylo -- 2) add the curLvl + 1 PhyloScale to the phylo
    $ addPhyloLevel (curLvl + 1) $ addPhyloScale (curLvl + 1)
    -- 1) update the current groups (with level parent pointers) in the phylo -- 1) update the current groups (with level parent pointers) in the phylo
    $ updatePhyloGroups curLvl (fromList $ map (\g -> (getGroupId g, g)) groups) phylo $ updatePhyloGroups curLvl (fromList $ map (\g -> (getGroupId g, g)) groups) phylo
    ...@@ -150,7 +150,7 @@ groupsToEdges prox sync nbDocs diago groups = ...@@ -150,7 +150,7 @@ groupsToEdges prox sync nbDocs diago groups =
    _ -> undefined _ -> undefined
    toParentId :: PhyloGroup -> PhyloGroupId 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] reduceGroups :: Proximity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
    ...@@ -166,7 +166,7 @@ reduceGroups prox sync docs diagos branch = ...@@ -166,7 +166,7 @@ reduceGroups prox sync docs diagos branch =
    in map (\comp -> in map (\comp ->
    -- 4) add to each groups their futur level parent group -- 4) add to each groups their futur level parent group
    let parentId = toParentId (head' "parentId" comp) 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 -- 3) reduce the graph a a set of related components
    $ toRelatedComponents groups edges) periods $ toRelatedComponents groups edges) periods
    ...@@ -185,7 +185,7 @@ adjustClustering sync branches = case sync of ...@@ -185,7 +185,7 @@ adjustClustering sync branches = case sync of
    levelUpAncestors :: [PhyloGroup] -> [PhyloGroup] levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
    levelUpAncestors groups = levelUpAncestors groups =
    -- 1) create an associative map of (old,new) ids -- 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 -> in map (\g ->
    let id' = ids' ! (getGroupId g) let id' = ids' ! (getGroupId g)
    ancestors = g ^. phylo_groupAncestors ancestors = g ^. phylo_groupAncestors
    ...@@ -206,7 +206,7 @@ synchronicClustering phylo = ...@@ -206,7 +206,7 @@ synchronicClustering phylo =
    $ phyloToLastBranches $ phyloToLastBranches
    $ traceSynchronyStart phylo $ traceSynchronyStart phylo
    newBranches' = newBranches `using` parList rdeepseq newBranches' = newBranches `using` parList rdeepseq
    in toNextLevel' phylo $ levelUpAncestors $ concat newBranches' in toNextScale phylo $ levelUpAncestors $ concat newBranches'
    -- synchronicDistance :: Phylo -> Level -> String -- synchronicDistance :: Phylo -> Level -> String
    ......
    src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
    View file @ 8790c9de
    ...@@ -13,7 +13,8 @@ module Gargantext.Core.Viz.Phylo.TemporalMatching where ...@@ -13,7 +13,8 @@ module Gargantext.Core.Viz.Phylo.TemporalMatching where
    import Control.Lens hiding (Level) import Control.Lens hiding (Level)
    import Control.Parallel.Strategies (parList, rdeepseq, using) import Control.Parallel.Strategies (parList, rdeepseq, using)
    import Data.List (concat, splitAt, tail, sortOn, (++), intersect, null, inits, groupBy, scanl, nub, nubBy, union, dropWhile, partition, or, sort, (!!)) import Data.Ord
    import Data.List (concat, splitAt, tail, sortOn, sortBy, (++), intersect, null, inits, groupBy, scanl, nub, nubBy, union, dropWhile, partition, or, sort, (!!))
    import Data.Map (Map, fromList, elems, restrictKeys, unionWith, findWithDefault, keys, (!), (!?), filterWithKey, singleton, empty, mapKeys, adjust) import Data.Map (Map, fromList, elems, restrictKeys, unionWith, findWithDefault, keys, (!), (!?), filterWithKey, singleton, empty, mapKeys, adjust)
    import Debug.Trace (trace) import Debug.Trace (trace)
    import Gargantext.Core.Viz.Phylo import Gargantext.Core.Viz.Phylo
    ...@@ -115,7 +116,7 @@ toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' = ...@@ -115,7 +116,7 @@ toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' =
    -- | Local Matching | -- -- | Local Matching | --
    ------------------------ ------------------------
    findLastPeriod :: Filiation -> [PhyloPeriodId] -> PhyloPeriodId findLastPeriod :: Filiation -> [Period] -> Period
    findLastPeriod fil periods = case fil of findLastPeriod fil periods = case fil of
    ToParents -> head' "findLastPeriod" (sortOn fst periods) ToParents -> head' "findLastPeriod" (sortOn fst periods)
    ToChilds -> last' "findLastPeriod" (sortOn fst periods) ToChilds -> last' "findLastPeriod" (sortOn fst periods)
    ...@@ -124,7 +125,7 @@ findLastPeriod fil periods = case fil of ...@@ -124,7 +125,7 @@ findLastPeriod fil periods = case fil of
    -- | To filter pairs of candidates related to old pointers periods -- | To filter pairs of candidates related to old pointers periods
    removeOldPointers :: [Pointer] -> Filiation -> Double -> Proximity -> PhyloPeriodId removeOldPointers :: [Pointer] -> Filiation -> Double -> Proximity -> Period
    -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
    -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
    removeOldPointers oldPointers fil thr prox prd pairs removeOldPointers oldPointers fil thr prox prd pairs
    ...@@ -144,7 +145,33 @@ removeOldPointers oldPointers fil thr prox prd pairs ...@@ -144,7 +145,33 @@ removeOldPointers oldPointers fil thr prox prd pairs
    | otherwise = [] | otherwise = []
    makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [PhyloPeriodId] -> [Pointer] -> Filiation -> Double -> Proximity
    makePairs :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [Period] -> [Pointer] -> Filiation -> Double -> Proximity
    -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
    makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos =
    if (null periods)
    then []
    else removeOldPointers oldPointers fil thr prox lastPrd
    {- at least on of the pair candidates should be from the last added period -}
    $ filter (\((id,_),(id',_)) -> ((fst . fst) id == lastPrd) || ((fst . fst) id' == lastPrd))
    $ filter (\((id,_),(id',_)) -> (elem id inPairs) || (elem id' inPairs))
    $ listToKeys candidates
    where
    --------------------------------------
    inPairs :: [PhyloGroupId]
    inPairs = map fst
    $ filter (\(id,ngrams) ->
    let nbDocs = (sum . elems) $ filterDocs docs ([(fst . fst) egoId, (fst . fst) id])
    diago = reduceDiagos $ filterDiago diagos ([(fst . fst) egoId, (fst . fst) id])
    in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr
    ) candidates
    --------------------------------------
    lastPrd :: Period
    lastPrd = findLastPeriod fil periods
    --------------------------------------
    makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [Period] -> [Pointer] -> Filiation -> Double -> Proximity
    -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
    makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos = makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos =
    if (null periods) if (null periods)
    ...@@ -159,7 +186,7 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d ...@@ -159,7 +186,7 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d
    in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr
    ) candidates ) candidates
    where where
    lastPrd :: PhyloPeriodId lastPrd :: Period
    lastPrd = findLastPeriod fil periods lastPrd = findLastPeriod fil periods
    ...@@ -190,16 +217,17 @@ filterPointersByPeriod fil pts = ...@@ -190,16 +217,17 @@ filterPointersByPeriod fil pts =
    phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc
    -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer] -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
    phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) = phyloGroupMatching candidates filiation proxi docs diagos thr oldPointers (id,ngrams) =
    if (null $ filterPointers proxi thr oldPointers) if (null $ filterPointers proxi thr oldPointers)
    {- let's find new pointers -} {- let's find new pointers -}
    then if null nextPointers then if null nextPointers
    then [] then []
    else filterPointersByPeriod fil else filterPointersByPeriod filiation
    $ head' "phyloGroupMatching" $ head' "phyloGroupMatching"
    -- Keep only the best set of pointers grouped by proximity -- Keep only the best set of pointers grouped by proximity
    $ groupBy (\pt pt' -> (snd . fst) pt == (snd . fst) pt') $ groupBy (\pt pt' -> (snd . fst) pt == (snd . fst) pt')
    $ reverse $ sortOn (snd . fst) $ head' "pointers" nextPointers -- verifier que l on garde bien les plus importants
    $ sortBy (comparing (Down . snd . fst)) $ head' "pointers" nextPointers
    -- Find the first time frame where at leats one pointer satisfies the proximity threshold -- Find the first time frame where at leats one pointer satisfies the proximity threshold
    else oldPointers else oldPointers
    where where
    ...@@ -212,8 +240,7 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -212,8 +240,7 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
    nbdocs = sum $ elems $ (filterDocs docs ([(fst . fst) id] ++ periods)) nbdocs = sum $ elems $ (filterDocs docs ([(fst . fst) id] ++ periods))
    diago = reduceDiagos diago = reduceDiagos
    $ filterDiago diagos ([(fst . fst) id] ++ periods) $ filterDiago diagos ([(fst . fst) id] ++ periods)
    {- important resize nbdocs et diago dans le make pairs -} pairs = makePairs (id,ngrams) (concat groups) periods oldPointers filiation thr proxi docs diagos
    pairs = makePairs' (id,ngrams) (concat groups) periods oldPointers fil thr proxi docs diagos
    in acc ++ ( filterPointers' proxi thr in acc ++ ( filterPointers' proxi thr
    $ concat $ concat
    $ map (\(c,c') -> $ map (\(c,c') ->
    ...@@ -225,10 +252,10 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -225,10 +252,10 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
    $ inits candidates -- groups from [[1900],[1900,1901],[1900,1901,1902],...] $ inits candidates -- groups from [[1900],[1900,1901],[1900,1901,1902],...]
    filterDocs :: Map Date Double -> [PhyloPeriodId] -> Map Date Double filterDocs :: Map Date Double -> [Period] -> Map Date Double
    filterDocs d pds = restrictKeys d $ periodsToYears pds filterDocs d pds = restrictKeys d $ periodsToYears pds
    filterDiago :: Map Date Cooc -> [PhyloPeriodId] -> Map Date Cooc filterDiago :: Map Date Cooc -> [Period] -> Map Date Cooc
    filterDiago diago pds = restrictKeys diago $ periodsToYears pds filterDiago diago pds = restrictKeys diago $ periodsToYears pds
    ...@@ -237,7 +264,7 @@ filterDiago diago pds = restrictKeys diago $ periodsToYears pds ...@@ -237,7 +264,7 @@ filterDiago diago pds = restrictKeys diago $ periodsToYears pds
    ----------------------------- -----------------------------
    getNextPeriods :: Filiation -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId] getNextPeriods :: Filiation -> Int -> Period -> [Period] -> [Period]
    getNextPeriods fil max' pId pIds = getNextPeriods fil max' pId pIds =
    case fil of case fil of
    ToChilds -> take max' $ (tail . snd) $ splitAt (elemIndex' pId pIds) pIds ToChilds -> take max' $ (tail . snd) $ splitAt (elemIndex' pId pIds) pIds
    ...@@ -255,7 +282,7 @@ getCandidates ego targets = ...@@ -255,7 +282,7 @@ getCandidates ego targets =
    map (\groups' -> filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g')) groups') targets map (\groups' -> filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g')) groups') targets
    matchGroupsToGroups :: Int -> [PhyloPeriodId] -> Proximity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup] matchGroupsToGroups :: Int -> [Period] -> Proximity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
    matchGroupsToGroups frame periods proximity thr docs coocs groups = matchGroupsToGroups frame periods proximity thr docs coocs groups =
    let groups' = groupByField _phylo_groupPeriod groups let groups' = groupByField _phylo_groupPeriod groups
    in foldl' (\acc prd -> in foldl' (\acc prd ->
    ...@@ -319,18 +346,6 @@ fScore lambda x periods bk bx = ...@@ -319,18 +346,6 @@ fScore lambda x periods bk bx =
    wk :: [PhyloGroup] -> Double wk :: [PhyloGroup] -> Double
    wk bk = fromIntegral $ length bk wk bk = fromIntegral $ length bk
    toPhyloQuality' :: Double -> Map Int Double -> [[PhyloGroup]] -> Double
    toPhyloQuality' lambda freq branches =
    if (null branches)
    then 0
    else sum
    $ map (\i ->
    let bks = relevantBranches i branches
    periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem i $ g ^. phylo_groupNgrams) $ concat bks
    in (freq ! i) * (sum $ map (\bk -> ((wk bk) / (sum $ map wk bks)) * (fScore lambda i periods bk bks)) bks))
    $ keys freq
    toRecall :: Map Int Double -> [[PhyloGroup]] -> Double toRecall :: Map Int Double -> [[PhyloGroup]] -> Double
    toRecall freq branches = toRecall freq branches =
    if (null branches) if (null branches)
    ...@@ -391,9 +406,8 @@ toPhyloQuality fdt lambda freq branches = ...@@ -391,9 +406,8 @@ toPhyloQuality fdt lambda freq branches =
    -- | Constant Temporal Matching | -- -- | Constant Temporal Matching | --
    ------------------------------------ ------------------------------------
    groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]] groupsToBranches groups =
    groupsToBranches' groups =
    {- run the related component algorithm -} {- run the related component algorithm -}
    let egos = groupBy (\gs gs' -> (fst $ fst $ head' "egos" gs) == (fst $ fst $ head' "egos" gs')) let egos = groupBy (\gs gs' -> (fst $ fst $ head' "egos" gs) == (fst $ fst $ head' "egos" gs'))
    $ sortOn (\gs -> fst $ fst $ head' "egos" gs) $ sortOn (\gs -> fst $ fst $ head' "egos" gs)
    ...@@ -427,12 +441,12 @@ updateThr thr branches = map (\b -> map (\g -> ...@@ -427,12 +441,12 @@ updateThr thr branches = map (\b -> map (\g ->
    -- ego = the current branch we want to break -- ego = the current branch we want to break
    -- rest = the branches we still have to break -- rest = the branches we still have to break
    breakBranches :: Double -> Proximity -> Double -> Map Int Double -> Int -> Double -> Double -> Double breakBranches :: Double -> Proximity -> Double -> Map Int Double -> Int -> Double -> Double -> Double
    -> Int -> Map Date Double -> Map Date Cooc -> [PhyloPeriodId] -> [([PhyloGroup],Bool)] -> ([PhyloGroup],Bool) -> [([PhyloGroup],Bool)] -> [([PhyloGroup],Bool)] -> Int -> Map Date Double -> Map Date Cooc -> [Period] -> [([PhyloGroup],Bool)] -> ([PhyloGroup],Bool) -> [([PhyloGroup],Bool)] -> [([PhyloGroup],Bool)]
    breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods done ego rest = breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods done ego rest =
    -- 1) keep or not the new division of ego -- 1) keep or not the new division of ego
    let done' = done ++ (if snd ego let done' = done ++ (if snd ego
    then then
    (if ((null (fst ego')) || (quality > quality')) (if ((null (fst ego')) || (quality > quality'))
    then then
    -- trace (" ✗ F(β) = " <> show(quality) <> " (vs) " <> show(quality') -- trace (" ✗ F(β) = " <> show(quality) <> " (vs) " <> show(quality')
    -- <> " | " <> show(length $ fst ego) <> " groups : " -- <> " | " <> show(length $ fst ego) <> " groups : "
    ...@@ -460,7 +474,7 @@ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame ...@@ -460,7 +474,7 @@ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame
    -------------------------------------- --------------------------------------
    ego' :: ([[PhyloGroup]],[[PhyloGroup]]) ego' :: ([[PhyloGroup]],[[PhyloGroup]])
    ego' = ego' =
    let branches = groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) let branches = groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
    $ matchGroupsToGroups frame periods proximity thr docs coocs (fst ego) $ matchGroupsToGroups frame periods proximity thr docs coocs (fst ego)
    branches' = branches `using` parList rdeepseq branches' = branches `using` parList rdeepseq
    in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) >= minBranch) in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) >= minBranch)
    ...@@ -473,11 +487,11 @@ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame ...@@ -473,11 +487,11 @@ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame
    seaLevelMatching :: Double -> Proximity -> Double -> Int -> Map Int Double -> Double -> Double -> Double -> Double seaLevelMatching :: Double -> Proximity -> Double -> Int -> Map Int Double -> Double -> Double -> Double -> Double
    -> Int -> [PhyloPeriodId] -> Map Date Double -> Map Date Cooc -> [([PhyloGroup],Bool)] -> [([PhyloGroup],Bool)] -> Int -> [Period] -> Map Date Double -> Map Date Cooc -> [([PhyloGroup],Bool)] -> ([([PhyloGroup],Bool)],Double)
    seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevation frame periods docs coocs branches = seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevation frame periods docs coocs branches =
    -- if there is no branch to break or if seaLvl level > 1 then end -- if there is no branch to break or if seaLvl level > 1 then end
    if (thr >= 1) || ((not . or) $ map snd branches) if (thr >= 1) || ((not . or) $ map snd branches)
    then branches then (branches, toPhyloQuality fdt lambda frequency (map fst branches))
    else else
    -- break all the possible branches at the current seaLvl level -- break all the possible branches at the current seaLvl level
    let quality = toPhyloQuality fdt lambda frequency (map fst branches) let quality = toPhyloQuality fdt lambda frequency (map fst branches)
    ...@@ -495,13 +509,13 @@ seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevati ...@@ -495,13 +509,13 @@ seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevati
    constanteTemporalMatching :: Double -> Double -> Phylo -> Phylo constanteTemporalMatching :: Double -> Double -> Phylo -> Phylo
    constanteTemporalMatching start step phylo = updatePhyloGroups 1 constanteTemporalMatching start step phylo = updatePhyloGroups 1
    (fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches) (fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat (map fst $ (fst branches)))
    (toPhyloHorizon phylo) (toPhyloHorizon (updateQuality (snd branches) phylo))
    where where
    -- 2) process the temporal matching by elevating seaLvl level -- 2) process the temporal matching by elevating seaLvl level
    branches :: [[PhyloGroup]] -- branches :: ([([groups in the same branch],should we still break the branch?)],final quality)
    branches = map fst branches :: ([([PhyloGroup],Bool)],Double)
    $ seaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo) branches = seaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo)
    (phyloProximity $ getConfig phylo) (phyloProximity $ getConfig phylo)
    (_qua_granularity $ phyloQuality $ getConfig phylo) (_qua_granularity $ phyloQuality $ getConfig phylo)
    (_qua_minBranch $ phyloQuality $ getConfig phylo) (_qua_minBranch $ phyloQuality $ getConfig phylo)
    ...@@ -518,7 +532,7 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1 ...@@ -518,7 +532,7 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
    -- here we suppose that all the groups of level 1 are part of the same big branch -- here we suppose that all the groups of level 1 are part of the same big branch
    groups :: [([PhyloGroup],Bool)] groups :: [([PhyloGroup],Bool)]
    groups = map (\b -> (b,(length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo))) groups = map (\b -> (b,(length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo)))
    $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
    $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo) $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo)
    (getPeriodIds phylo) (phyloProximity $ getConfig phylo) (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
    start start
    ...@@ -583,7 +597,7 @@ toThreshold lvl proxiGroups = ...@@ -583,7 +597,7 @@ toThreshold lvl proxiGroups =
    -- rest = the branches we still have to break -- rest = the branches we still have to break
    adaptativeBreakBranches :: Double -> Proximity -> Double -> Double -> Map (PhyloGroupId,PhyloGroupId) Double adaptativeBreakBranches :: Double -> Proximity -> Double -> Double -> Map (PhyloGroupId,PhyloGroupId) Double
    -> Double -> Map Int Double -> Int -> Int -> Map Date Double -> Map Date Cooc -> Double -> Map Int Double -> Int -> Int -> Map Date Double -> Map Date Cooc
    -> [PhyloPeriodId] -> [([PhyloGroup],(Bool,[Double]))] -> ([PhyloGroup],(Bool,[Double])) -> [([PhyloGroup],(Bool,[Double]))] -> [Period] -> [([PhyloGroup],(Bool,[Double]))] -> ([PhyloGroup],(Bool,[Double])) -> [([PhyloGroup],(Bool,[Double]))]
    -> [([PhyloGroup],(Bool,[Double]))] -> [([PhyloGroup],(Bool,[Double]))]
    adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods done ego rest = adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods done ego rest =
    -- 1) keep or not the new division of ego -- 1) keep or not the new division of ego
    ...@@ -617,7 +631,7 @@ adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda freque ...@@ -617,7 +631,7 @@ adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda freque
    -------------------------------------- --------------------------------------
    ego' :: ([[PhyloGroup]],[[PhyloGroup]]) ego' :: ([[PhyloGroup]],[[PhyloGroup]])
    ego' = ego' =
    let branches = groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) let branches = groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
    $ matchGroupsToGroups frame periods proxiConf thr docs coocs (fst ego) $ matchGroupsToGroups frame periods proxiConf thr docs coocs (fst ego)
    branches' = branches `using` parList rdeepseq branches' = branches `using` parList rdeepseq
    in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) > minBranch) in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) > minBranch)
    ...@@ -631,7 +645,7 @@ adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda freque ...@@ -631,7 +645,7 @@ adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda freque
    adaptativeSeaLevelMatching :: Double -> Proximity -> Double -> Double -> Map (PhyloGroupId, PhyloGroupId) Double adaptativeSeaLevelMatching :: Double -> Proximity -> Double -> Double -> Map (PhyloGroupId, PhyloGroupId) Double
    -> Double -> Int -> Map Int Double -> Double -> Int -> Map Int Double
    -> Int -> [PhyloPeriodId] -> Map Date Double -> Map Date Cooc -> Int -> [Period] -> Map Date Double -> Map Date Cooc
    -> [([PhyloGroup],(Bool,[Double]))] -> [([PhyloGroup],(Bool,[Double]))] -> [([PhyloGroup],(Bool,[Double]))] -> [([PhyloGroup],(Bool,[Double]))]
    adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minBranch frequency frame periods docs coocs branches = adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minBranch frequency frame periods docs coocs branches =
    -- if there is no branch to break or if seaLvl level >= depth then end -- if there is no branch to break or if seaLvl level >= depth then end
    ...@@ -676,7 +690,7 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1 ...@@ -676,7 +690,7 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
    -- here we suppose that all the groups of level 1 are part of the same big branch -- here we suppose that all the groups of level 1 are part of the same big branch
    groups :: [([PhyloGroup],(Bool,[Double]))] groups :: [([PhyloGroup],(Bool,[Double]))]
    groups = map (\b -> (b,((length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo),[thr]))) groups = map (\b -> (b,((length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo),[thr])))
    $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
    $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo) $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo)
    (getPeriodIds phylo) (phyloProximity $ getConfig phylo) (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
    thr thr
    ......
    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