Skip to content

haskell-gargantext
haskell-gargantext
Commit 2da4252e authored by qlobbe's avatar qlobbe
Browse files
Options

add the ancestors

parent 04aa2d5c
Pipeline #938 failed with stage
    Expand all Hide whitespace changes
    Inline Side-by-side
    Showing with 169 additions and 111 deletions
    src/Gargantext/Viz/AdaptativePhylo.hs
    View file @ 2da4252e
    ......@@ -143,7 +143,7 @@ defaultConfig =
    , phyloName = pack "Default Phylo"
    , phyloLevel = 2
    , phyloProximity = WeightedLogJaccard 10
    , seaElevation = Constante 0.6 1
    , seaElevation = Constante 0.1 0.1
    , phyloSynchrony = ByProximityThreshold 0.5 10 SiblingBranches MergeAllGroups
    , phyloQuality = Quality 100 1
    , timeUnit = Year 3 1 5
    ......@@ -326,6 +326,7 @@ data PhyloGroup =
    , _phylo_groupLevelChilds :: [Pointer]
    , _phylo_groupPeriodParents :: [Pointer]
    , _phylo_groupPeriodChilds :: [Pointer]
    , _phylo_groupAncestors :: [Pointer]
    }
    deriving (Generic, Show, Eq, NFData)
    ......@@ -352,24 +353,13 @@ data PhyloClique = PhyloClique
    , _phyloClique_period :: (Date,Date)
    } deriving (Generic,NFData,Show,Eq)
    ------------------------
    -- | Phylo Ancestor | --
    ------------------------
    data PhyloAncestor = PhyloAncestor
    { _phyloAncestor_id :: Int
    , _phyloAncestor_ngrams :: [Int]
    , _phyloAncestor_groups :: [PhyloGroupId]
    } deriving (Generic,NFData,Show,Eq)
    ----------------
    -- | Export | --
    ----------------
    type DotId = TextLazy.Text
    data EdgeType = GroupToGroup | BranchToGroup | BranchToBranch | PeriodToPeriod deriving (Show,Generic,Eq)
    data EdgeType = GroupToGroup | BranchToGroup | BranchToBranch | GroupToAncestor | PeriodToPeriod deriving (Show,Generic,Eq)
    data Filter = ByBranchSize { _branch_size :: Double } deriving (Show,Generic,Eq)
    ......@@ -405,7 +395,6 @@ data PhyloExport =
    PhyloExport
    { _export_groups :: [PhyloGroup]
    , _export_branches :: [PhyloBranch]
    , _export_ancestors :: [PhyloAncestor]
    } deriving (Generic, Show)
    ----------------
    ......
    src/Gargantext/Viz/Phylo/PhyloExample.hs
    View file @ 2da4252e
    ......@@ -137,9 +137,9 @@ actants = [ "Cleopatre" , "Ptolemee", "Ptolemee-XIII", "Ptolemee-XIV", "Ptolem
    corpus :: [(Date, Text)]
    corpus = sortOn fst [
    (-101,"La tutelle de sa mère lui étant difficile à endurer, en septembre 101 av. J.-C., Ptolemee-X la fait assassiner et peut enfin régner presque seul puisqu'il partage le pouvoir avec son épouse Berenice-III Cléopâtre Philopator."),
    (-101,"La tutelle Cesar Caesar-III de sa mère lui étant difficile à endurer, en septembre 101 av. J.-C., Ptolemee-X la fait assassiner et peut enfin régner presque seul puisqu'il partage le pouvoir avec son épouse Berenice-III Cléopâtre Philopator."),
    (-99,"Caesar-III est questeur en 99 av. J.-C. ou 98 av. J.-C., et préteur en 92 av. J.-C.."),
    (-100,"Caius Julius Caesar-IV — dit Jules Cesar — naît vers 100 av. J.-C., il est le fils de Caius Julius Caesar-III et de Aurelia-Cotta"),
    (-100,"Caius Julius Caesar-IV — dit Jules Cesar Ptolemee-X — naît vers 100 av. J.-C., il est le fils de Caius Julius Caesar-III et de Aurelia-Cotta"),
    (-85,"Caesar-III meurt à Pisae de cause naturelle en 85 av. J.-C. : selon Pline l'Ancien, il décède brusquement en mettant ses chaussures"),
    (-53,"Aurelia-Cotta décède peu de temps avant le meurtre de Clodius Pulcher, vers 53 av. J.-C."),
    (-51,"Cleopatre règne sur l’egypte entre 51 et 30 av. J.-C. avec ses frères-epoux Ptolemee-XIII et Ptolemee-XIV, puis aux côtes du general romain Marc-Antoine. Elle est celèbre pour avoir ete la compagne de Jules Cesar puis d'Antoine, avec lesquels elle a eu plusieurs enfants. Partie prenante dans la guerre civile opposant Antoine à Octave, elle est vaincue à la bataille d'Actium en 31 av. J.-C. Sa defaite va permettre aux Romains de mener à bien la conquête de l’egypte, evenement qui marquera la fin de l'epoque hellenistique."),
    ......
    src/Gargantext/Viz/Phylo/PhyloExport.hs
    View file @ 2da4252e
    This diff is collapsed.
    src/Gargantext/Viz/Phylo/PhyloMaker.hs
    View file @ 2da4252e
    ......@@ -36,7 +36,6 @@ import Control.Lens hiding (Level)
    import qualified Data.Vector as Vector
    import qualified Data.Set as Set
    ------------------
    -- | To Phylo | --
    ------------------
    ......@@ -119,7 +118,7 @@ cliqueToGroup fis pId lvl idx coocs = PhyloGroup pId lvl idx ""
    (ngramsToCooc (fis ^. phyloClique_nodes) coocs)
    (1,[0]) -- | branchid (lvl,[path in the branching tree])
    (fromList [("breaks",[0]),("seaLevels",[0])])
    [] [] [] []
    [] [] [] [] []
    toPhylo1 :: [Document] -> Phylo -> Phylo
    ......
    src/Gargantext/Viz/Phylo/PhyloTools.hs
    View file @ 2da4252e
    ......@@ -17,9 +17,9 @@ Portability : POSIX
    module Gargantext.Viz.Phylo.PhyloTools where
    import Data.Vector (Vector, elemIndex)
    import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy)
    import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, maximum, group)
    import Data.Set (Set, disjoint)
    import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty)
    import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
    import Data.String (String)
    import Data.Text (Text, unwords)
    ......@@ -257,22 +257,19 @@ ngramsToCooc ngrams coocs =
    --------------------
    getGroupId :: PhyloGroup -> PhyloGroupId
    getGroupId group = ((group ^. phylo_groupPeriod, group ^. phylo_groupLevel), group ^. phylo_groupIndex)
    getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupLevel), g ^. phylo_groupIndex)
    idToPrd :: PhyloGroupId -> PhyloPeriodId
    idToPrd id = (fst . fst) id
    getGroupThr :: PhyloGroup -> Double
    getGroupThr group = last' "getGroupThr" ((group ^. phylo_groupMeta) ! "breaks")
    groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] -> Map a [PhyloGroup]
    groupByField toField groups = fromListWith (++) $ map (\g -> (toField g, [g])) groups
    getPeriodPointers :: Filiation -> PhyloGroup -> [Pointer]
    getPeriodPointers fil group =
    getPeriodPointers fil g =
    case fil of
    ToChilds -> group ^. phylo_groupPeriodChilds
    ToParents -> group ^. phylo_groupPeriodParents
    ToChilds -> g ^. phylo_groupPeriodChilds
    ToParents -> g ^. phylo_groupPeriodParents
    filterProximity :: Proximity -> Double -> Double -> Bool
    filterProximity proximity thr local =
    ......@@ -291,14 +288,14 @@ getProximityName proximity =
    ---------------
    addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
    addPointers fil pty pointers group =
    addPointers fil pty pointers g =
    case pty of
    TemporalPointer -> case fil of
    ToChilds -> group & phylo_groupPeriodChilds .~ pointers
    ToParents -> group & phylo_groupPeriodParents .~ pointers
    ToChilds -> g & phylo_groupPeriodChilds .~ pointers
    ToParents -> g & phylo_groupPeriodParents .~ pointers
    LevelPointer -> case fil of
    ToChilds -> group & phylo_groupLevelChilds .~ pointers
    ToParents -> group & phylo_groupLevelParents .~ pointers
    ToChilds -> g & phylo_groupLevelChilds .~ pointers
    ToParents -> g & phylo_groupLevelParents .~ pointers
    getPeriodIds :: Phylo -> [(Date,Date)]
    ......@@ -375,12 +372,12 @@ updatePhyloGroups lvl m phylo =
    . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
    . phylo_levelGroups
    . traverse
    ) (\group ->
    let id = getGroupId group
    ) (\g ->
    let id = getGroupId g
    in
    if member id m
    then m ! id
    else group ) phylo
    else g ) phylo
    traceToPhylo :: Level -> Phylo -> Phylo
    ......@@ -393,6 +390,43 @@ traceToPhylo lvl phylo =
    -- | Clustering | --
    --------------------
    mergeBranchIds :: [[Int]] -> [Int]
    mergeBranchIds ids = (head' "mergeBranchIds" . sort . mostFreq') ids
    where
    -- | 2) find the most Up Left ids in the hierarchy of similarity
    -- mostUpLeft :: [[Int]] -> [[Int]]
    -- mostUpLeft ids' =
    -- let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
    -- inf = (fst . minimum) groupIds
    -- in map snd $ filter (\gIds -> fst gIds == inf) groupIds
    -- | 1) find the most frequent ids
    mostFreq' :: [[Int]] -> [[Int]]
    mostFreq' ids' =
    let groupIds = (map (\gIds -> (length gIds, head' "gIds" gIds)) . group . sort) ids'
    sup = (fst . maximum) groupIds
    in map snd $ filter (\gIds -> fst gIds == sup) groupIds
    mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
    mergeMeta bId groups =
    let ego = head' "mergeMeta" $ filter (\g -> (snd (g ^. phylo_groupBranchId)) == bId) groups
    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
    groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches groups =
    -- | run the related component algorithm
    let egos = map (\g -> [getGroupId g]
    ++ (map fst $ g ^. phylo_groupPeriodParents)
    ++ (map fst $ g ^. phylo_groupPeriodChilds)
    ++ (map fst $ g ^. phylo_groupAncestors)) $ elems groups
    graph = relatedComponents egos
    -- | update each group's branch id
    in map (\ids ->
    let groups' = elems $ restrictKeys groups (Set.fromList ids)
    bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
    in map (\g -> g & phylo_groupBranchId %~ (\(lvl,_) -> (lvl,bId))) groups') graph
    relatedComponents :: Ord a => [[a]] -> [[a]]
    relatedComponents graph = foldl' (\acc groups ->
    if (null acc)
    ......
    src/Gargantext/Viz/Phylo/SynchronicClustering.hs
    View file @ 2da4252e
    ......@@ -21,57 +21,19 @@ import Gargantext.Viz.Phylo.PhyloTools
    import Gargantext.Viz.Phylo.TemporalMatching (weightedLogJaccard', filterDiago, reduceDiagos)
    import Gargantext.Viz.Phylo.PhyloExport (processDynamics)
    import Data.List ((++), null, intersect, nub, concat, sort, sortOn, all, groupBy, group, maximum)
    import Data.List ((++), null, intersect, nub, concat, sort, sortOn, all, groupBy)
    import Data.Map (Map, fromList, fromListWith, foldlWithKey, (!), insert, empty, restrictKeys, elems, mapWithKey, member)
    import Data.Text (Text)
    import Control.Lens hiding (Level)
    import Control.Parallel.Strategies (parList, rdeepseq, using)
    -- import Debug.Trace (trace)
    import qualified Data.Map as Map
    import qualified Data.Set as Set
    -------------------------
    -- | New Level Maker | --
    -------------------------
    mergeBranchIds :: [[Int]] -> [Int]
    mergeBranchIds ids = (head' "mergeBranchIds" . sort . mostFreq') ids
    where
    -- | 2) find the most Up Left ids in the hierarchy of similarity
    -- mostUpLeft :: [[Int]] -> [[Int]]
    -- mostUpLeft ids' =
    -- let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
    -- inf = (fst . minimum) groupIds
    -- in map snd $ filter (\gIds -> fst gIds == inf) groupIds
    -- | 1) find the most frequent ids
    mostFreq' :: [[Int]] -> [[Int]]
    mostFreq' ids' =
    let groupIds = (map (\gIds -> (length gIds, head' "gIds" gIds)) . group . sort) ids'
    sup = (fst . maximum) groupIds
    in map snd $ filter (\gIds -> fst gIds == sup) groupIds
    mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
    mergeMeta bId groups =
    let ego = head' "mergeMeta" $ filter (\g -> (snd (g ^. phylo_groupBranchId)) == bId) groups
    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
    groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches' groups =
    -- | run the related component algorithm
    let egos = map (\g -> [getGroupId g]
    ++ (map fst $ g ^. phylo_groupPeriodParents)
    ++ (map fst $ g ^. phylo_groupPeriodChilds) ) $ elems groups
    graph = relatedComponents egos
    -- | update each group's branch id
    in map (\ids ->
    let groups' = elems $ restrictKeys groups (Set.fromList ids)
    bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
    in map (\g -> g & phylo_groupBranchId %~ (\(lvl,_) -> (lvl,bId))) groups') graph
    -------------------------
    mergeGroups :: [Cooc] -> PhyloGroupId -> Map PhyloGroupId PhyloGroupId -> [PhyloGroup] -> PhyloGroup
    ......@@ -84,6 +46,7 @@ mergeGroups coocs id mapIds childs =
    (mergeMeta bId childs) [] (map (\g -> (getGroupId g, 1)) childs)
    (updatePointers $ concat $ map _phylo_groupPeriodParents childs)
    (updatePointers $ concat $ map _phylo_groupPeriodChilds childs)
    []
    where
    --------------------
    bId :: [Int]
    ......@@ -104,7 +67,7 @@ toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
    toNextLevel' phylo groups =
    let curLvl = getLastLevel phylo
    oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
    newGroups = concat $ groupsToBranches'
    newGroups = concat $ groupsToBranches
    $ fromList $ map (\g -> (getGroupId g, g))
    $ foldlWithKey (\acc id groups' ->
    -- | 4) create the parent group
    ......
    src/Gargantext/Viz/Phylo/TemporalMatching.hs
    View file @ 2da4252e
    ......@@ -345,8 +345,8 @@ toPhyloQuality beta freq branches =
    ------------------------------------
    groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches groups =
    groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
    groupsToBranches' groups =
    -- | run the related component algorithm
    let egos = groupBy (\gs gs' -> (fst $ fst $ head' "egos" gs) == (fst $ fst $ head' "egos" gs'))
    $ sortOn (\gs -> fst $ fst $ head' "egos" gs)
    ......@@ -413,7 +413,7 @@ breakBranches proximity beta frequency minBranch thr depth elevation frame docs
    --------------------------------------
    ego' :: ([[PhyloGroup]],[[PhyloGroup]])
    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)
    branches' = branches `using` parList rdeepseq
    in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) >= minBranch)
    ......@@ -470,7 +470,7 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
    -- | here we suppose that all the groups of level 1 are part of the same big branch
    groups :: [([PhyloGroup],Bool)]
    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)
    (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
    start
    ......@@ -569,7 +569,7 @@ adaptativeBreakBranches proxiConf depth elevation groupsProxi beta frequency min
    --------------------------------------
    ego' :: ([[PhyloGroup]],[[PhyloGroup]])
    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)
    branches' = branches `using` parList rdeepseq
    in partition (\b -> (length $ nub $ map _phylo_groupPeriod b) > minBranch)
    ......@@ -627,7 +627,7 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
    -- | here we suppose that all the groups of level 1 are part of the same big branch
    groups :: [([PhyloGroup],(Bool,[Double]))]
    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)
    (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
    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