Skip to content

haskell-gargantext
haskell-gargantext
Commit dc29199c authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FEAT] Bulding phylo with graphviz

parent e1b6117a
Hide whitespace changes
Inline Side-by-side
Showing with 149 additions and 147 deletions
nix/pkgs.nix
View file @ dc29199c
...@@ -28,6 +28,7 @@ rec { ...@@ -28,6 +28,7 @@ rec {
# gfortran7.cc.lib # gfortran7.cc.lib
expat expat
icu icu
graphviz
]; ];
libPaths = pkgs.lib.makeLibraryPath nonhsBuildInputs; libPaths = pkgs.lib.makeLibraryPath nonhsBuildInputs;
shellHook = '' shellHook = ''
......
package.yaml
View file @ dc29199c
...@@ -203,6 +203,7 @@ library: ...@@ -203,6 +203,7 @@ library:
- postgresql-simple - postgresql-simple
- pretty-simple - pretty-simple
- probability - probability
- process
- product-profunctors - product-profunctors
- profunctors - profunctors
- protolude - protolude
......
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @ dc29199c
...@@ -368,7 +368,7 @@ sortByBirthDate order export = ...@@ -368,7 +368,7 @@ sortByBirthDate order export =
processSort :: Sort -> SeaElevation -> PhyloExport -> PhyloExport processSort :: Sort -> SeaElevation -> PhyloExport -> PhyloExport
processSort sort' elev export = case sort' of processSort sort' elev export = case sort' of
ByBirthDate o -> sortByBirthDate o export ByBirthDate o -> sortByBirthDate o export
ByHierarchy -> export & export_branches .~ (branchToIso' (_cons_start elev) (_cons_step elev) ByHierarchy _ -> export & export_branches .~ (branchToIso' (_cons_start elev) (_cons_step elev)
$ sortByHierarchy 0 (export ^. export_branches)) $ sortByHierarchy 0 (export ^. export_branches))
......
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @ dc29199c
...@@ -43,7 +43,7 @@ sumInvLog' s nb diago = foldl (\mem occ -> mem + (1 / (log (occ + 1/ tan (s * pi ...@@ -43,7 +43,7 @@ sumInvLog' s nb diago = foldl (\mem occ -> mem + (1 / (log (occ + 1/ tan (s * pi
-- | Process the sumLog -- | Process the sumLog
sumLog' :: Double -> Double -> [Double] -> Double sumLog' :: Double -> Double -> [Double] -> Double
sumLog' s nb diago = foldl (\mem occ -> mem + (log (occ + 1/ tan (s * pi / 2)) / log (nb + 1/ tan (s * pi / 2)))) 0 diago sumLog' s nb diago = foldl (\mem occ -> mem + (log (occ + 1/ tan (s * pi / 2)) / log (nb + 1/ tan (s * pi / 2)))) 0 diago
weightedLogJaccard' :: Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double weightedLogJaccard' :: Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double
...@@ -52,64 +52,64 @@ weightedLogJaccard' sens nbDocs diago ngrams ngrams' ...@@ -52,64 +52,64 @@ weightedLogJaccard' sens nbDocs diago ngrams ngrams'
| ngramsInter == ngramsUnion = 1 | ngramsInter == ngramsUnion = 1
| sens == 0 = jaccard ngramsInter ngramsUnion | sens == 0 = jaccard ngramsInter ngramsUnion
| sens > 0 = (sumInvLog' sens nbDocs diagoInter) / (sumInvLog' sens nbDocs diagoUnion) | sens > 0 = (sumInvLog' sens nbDocs diagoInter) / (sumInvLog' sens nbDocs diagoUnion)
| otherwise = (sumLog' sens nbDocs diagoInter) / (sumLog' sens nbDocs diagoUnion) | otherwise = (sumLog' sens nbDocs diagoInter) / (sumLog' sens nbDocs diagoUnion)
where where
-------------------------------------- --------------------------------------
ngramsInter :: [Int] ngramsInter :: [Int]
ngramsInter = intersect ngrams ngrams' ngramsInter = intersect ngrams ngrams'
-------------------------------------- --------------------------------------
ngramsUnion :: [Int] ngramsUnion :: [Int]
ngramsUnion = union ngrams ngrams' ngramsUnion = union ngrams ngrams'
-------------------------------------- --------------------------------------
diagoInter :: [Double] diagoInter :: [Double]
diagoInter = elems $ restrictKeys diago (Set.fromList ngramsInter) diagoInter = elems $ restrictKeys diago (Set.fromList ngramsInter)
-------------------------------------- --------------------------------------
diagoUnion :: [Double] diagoUnion :: [Double]
diagoUnion = elems $ restrictKeys diago (Set.fromList ngramsUnion) diagoUnion = elems $ restrictKeys diago (Set.fromList ngramsUnion)
-------------------------------------- --------------------------------------
-- | Process the weighted similarity between clusters. Adapted from Wang, X., Cheng, Q., Lu, W., 2014. Analyzing evolution of research topics with NEViewer: a new method based on dynamic co-word networks. Scientometrics 101, 1253–1271. https://doi.org/10.1007/s11192-014-1347-y (log added in the formula + pair comparison) -- | Process the weighted similarity between clusters. Adapted from Wang, X., Cheng, Q., Lu, W., 2014. Analyzing evolution of research topics with NEViewer: a new method based on dynamic co-word networks. Scientometrics 101, 1253–1271. https://doi.org/10.1007/s11192-014-1347-y (log added in the formula + pair comparison)
-- tests not conclusive -- tests not conclusive
weightedLogSim' :: Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double weightedLogSim' :: Double -> Double -> Map Int Double -> [Int] -> [Int] -> Double
weightedLogSim' sens nbDocs diago ego_ngrams target_ngrams weightedLogSim' sens nbDocs diago ego_ngrams target_ngrams
| null ngramsInter = 0 | null ngramsInter = 0
| ngramsInter == ngramsUnion = 1 | ngramsInter == ngramsUnion = 1
| sens == 0 = jaccard ngramsInter ngramsUnion | sens == 0 = jaccard ngramsInter ngramsUnion
| sens > 0 = (sumInvLog' sens nbDocs diagoInter) / minimum [(sumInvLog' sens nbDocs diagoEgo),(sumInvLog' sens nbDocs diagoTarget)] | sens > 0 = (sumInvLog' sens nbDocs diagoInter) / minimum [(sumInvLog' sens nbDocs diagoEgo),(sumInvLog' sens nbDocs diagoTarget)]
| otherwise = (sumLog' sens nbDocs diagoInter) / minimum [(sumLog' sens nbDocs diagoEgo),(sumLog' sens nbDocs diagoTarget)] | otherwise = (sumLog' sens nbDocs diagoInter) / minimum [(sumLog' sens nbDocs diagoEgo),(sumLog' sens nbDocs diagoTarget)]
where where
-------------------------------------- --------------------------------------
ngramsInter :: [Int] ngramsInter :: [Int]
ngramsInter = intersect ego_ngrams target_ngrams ngramsInter = intersect ego_ngrams target_ngrams
-------------------------------------- --------------------------------------
ngramsUnion :: [Int] ngramsUnion :: [Int]
ngramsUnion = union ego_ngrams target_ngrams ngramsUnion = union ego_ngrams target_ngrams
-------------------------------------- --------------------------------------
diagoInter :: [Double] diagoInter :: [Double]
diagoInter = elems $ restrictKeys diago (Set.fromList ngramsInter) diagoInter = elems $ restrictKeys diago (Set.fromList ngramsInter)
-------------------------------------- --------------------------------------
diagoEgo :: [Double] diagoEgo :: [Double]
diagoEgo = elems $ restrictKeys diago (Set.fromList ego_ngrams) diagoEgo = elems $ restrictKeys diago (Set.fromList ego_ngrams)
-------------------------------------- --------------------------------------
diagoTarget :: [Double] diagoTarget :: [Double]
diagoTarget = elems $ restrictKeys diago (Set.fromList target_ngrams) diagoTarget = elems $ restrictKeys diago (Set.fromList target_ngrams)
-------------------------------------- --------------------------------------
toProximity :: Double -> Map Int Double -> Proximity -> [Int] -> [Int] -> [Int] -> Double toProximity :: Double -> Map Int Double -> Proximity -> [Int] -> [Int] -> [Int] -> Double
-- | To process the proximity between a current group and a pair of targets group using the adapted Wang et al. Similarity -- | To process the proximity between a current group and a pair of targets group using the adapted Wang et al. Similarity
toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' = toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' =
case proximity of case proximity of
WeightedLogJaccard sens -> WeightedLogJaccard sens ->
let pairNgrams = if targetNgrams == targetNgrams' let pairNgrams = if targetNgrams == targetNgrams'
then targetNgrams then targetNgrams
else union targetNgrams targetNgrams' else union targetNgrams targetNgrams'
in weightedLogJaccard' sens nbDocs diago egoNgrams pairNgrams in weightedLogJaccard' sens nbDocs diago egoNgrams pairNgrams
WeightedLogSim sens -> WeightedLogSim sens ->
let pairNgrams = if targetNgrams == targetNgrams' let pairNgrams = if targetNgrams == targetNgrams'
then targetNgrams then targetNgrams
else union targetNgrams targetNgrams' else union targetNgrams targetNgrams'
in weightedLogSim' sens nbDocs diago egoNgrams pairNgrams in weightedLogSim' sens nbDocs diago egoNgrams pairNgrams
Hamming -> undefined Hamming _ -> undefined
------------------------ ------------------------
-- | Local Matching | -- -- | Local Matching | --
...@@ -124,16 +124,16 @@ findLastPeriod fil periods = case fil of ...@@ -124,16 +124,16 @@ 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 -> PhyloPeriodId
-> [((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
| null oldPointers = pairs | null oldPointers = pairs
| null (filterPointers prox thr oldPointers) = | null (filterPointers prox thr oldPointers) =
let lastMatchedPrd = findLastPeriod fil (map (fst . fst . fst) oldPointers) let lastMatchedPrd = findLastPeriod fil (map (fst . fst . fst) oldPointers)
in if lastMatchedPrd == prd in if lastMatchedPrd == prd
then [] then []
else filter (\((id,_),(id',_)) -> else filter (\((id,_),(id',_)) ->
case fil of case fil of
ToChildsMemory -> undefined ToChildsMemory -> undefined
ToParentsMemory -> undefined ToParentsMemory -> undefined
...@@ -146,8 +146,8 @@ removeOldPointers oldPointers fil thr prox prd pairs ...@@ -146,8 +146,8 @@ removeOldPointers oldPointers fil thr prox prd pairs
makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [PhyloPeriodId] -> [Pointer] -> Filiation -> Double -> Proximity makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [PhyloPeriodId] -> [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)
then [] then []
else removeOldPointers oldPointers fil thr prox lastPrd else removeOldPointers oldPointers fil thr prox lastPrd
{- at least on of the pair candidates should be from the last added period -} {- at least on of the pair candidates should be from the last added period -}
...@@ -156,9 +156,9 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d ...@@ -156,9 +156,9 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d
$ filter (\(id,ngrams) -> $ filter (\(id,ngrams) ->
let nbDocs = (sum . elems) $ filterDocs docs ([(fst . fst) egoId, (fst . fst) id]) let nbDocs = (sum . elems) $ filterDocs docs ([(fst . fst) egoId, (fst . fst) id])
diago = reduceDiagos $ filterDiago diagos ([(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 in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr
) candidates ) candidates
where where
lastPrd :: PhyloPeriodId lastPrd :: PhyloPeriodId
lastPrd = findLastPeriod fil periods lastPrd = findLastPeriod fil periods
...@@ -175,13 +175,13 @@ reduceDiagos diagos = mapKeys (\(k,_) -> k) ...@@ -175,13 +175,13 @@ reduceDiagos diagos = mapKeys (\(k,_) -> k)
$ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos) $ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos)
filterPointersByPeriod :: Filiation -> [(Pointer,[Int])] -> [Pointer] filterPointersByPeriod :: Filiation -> [(Pointer,[Int])] -> [Pointer]
filterPointersByPeriod fil pts = filterPointersByPeriod fil pts =
let pts' = sortOn (fst . fst . fst . fst) pts let pts' = sortOn (fst . fst . fst . fst) pts
inf = (fst . fst . fst . fst) $ head' "filterPointersByPeriod" pts' inf = (fst . fst . fst . fst) $ head' "filterPointersByPeriod" pts'
sup = (fst . fst . fst . fst) $ last' "filterPointersByPeriod" pts' sup = (fst . fst . fst . fst) $ last' "filterPointersByPeriod" pts'
in map fst in map fst
$ nubBy (\pt pt' -> snd pt == snd pt') $ nubBy (\pt pt' -> snd pt == snd pt')
$ filter (\pt -> ((fst . fst . fst . fst) pt == inf) || ((fst . fst . fst . fst) pt == sup)) $ filter (\pt -> ((fst . fst . fst . fst) pt == inf) || ((fst . fst . fst . fst) pt == sup))
$ case fil of $ case fil of
ToParents -> reverse pts' ToParents -> reverse pts'
ToChilds -> pts' ToChilds -> pts'
...@@ -190,7 +190,7 @@ filterPointersByPeriod fil pts = ...@@ -190,7 +190,7 @@ 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 fil 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
...@@ -210,19 +210,19 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -210,19 +210,19 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
$ scanl (\acc groups -> $ scanl (\acc groups ->
let periods = nub $ map (fst . fst . fst) $ concat groups let periods = nub $ map (fst . fst . fst) $ concat groups
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 -} {- important resize nbdocs et diago dans le make pairs -}
pairs = makePairs' (id,ngrams) (concat groups) periods oldPointers fil 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') ->
{- process the proximity between the current group and a pair of candidates -} {- process the proximity between the current group and a pair of candidates -}
let proximity = toProximity nbdocs diago proxi ngrams (snd c) (snd c') let proximity = toProximity nbdocs diago proxi ngrams (snd c) (snd c')
in if ((c == c') || (snd c == snd c')) in if ((c == c') || (snd c == snd c'))
then [((fst c,proximity),snd c)] then [((fst c,proximity),snd c)]
else [((fst c,proximity),snd c),((fst c',proximity),snd c')] ) pairs )) [] else [((fst c,proximity),snd c),((fst c',proximity),snd c')] ) pairs )) []
$ 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 -> [PhyloPeriodId] -> Map Date Double
...@@ -238,8 +238,8 @@ filterDiago diago pds = restrictKeys diago $ periodsToYears pds ...@@ -238,8 +238,8 @@ filterDiago diago pds = restrictKeys diago $ periodsToYears pds
getNextPeriods :: Filiation -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId] getNextPeriods :: Filiation -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
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
ToParents -> take max' $ (reverse . fst) $ splitAt (elemIndex' pId pIds) pIds ToParents -> take max' $ (reverse . fst) $ splitAt (elemIndex' pId pIds) pIds
ToChildsMemory -> undefined ToChildsMemory -> undefined
...@@ -247,8 +247,8 @@ getNextPeriods fil max' pId pIds = ...@@ -247,8 +247,8 @@ getNextPeriods fil max' pId pIds =
getCandidates :: PhyloGroup -> [[(PhyloGroupId,[Int])]] -> [[(PhyloGroupId,[Int])]] getCandidates :: PhyloGroup -> [[(PhyloGroupId,[Int])]] -> [[(PhyloGroupId,[Int])]]
getCandidates ego targets = getCandidates ego targets =
map (\groups' -> map (\groups' ->
filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g') filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g')
) groups') targets ) groups') targets
...@@ -256,13 +256,13 @@ getCandidates ego targets = ...@@ -256,13 +256,13 @@ getCandidates ego targets =
matchGroupsToGroups :: Int -> [PhyloPeriodId] -> Proximity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup] matchGroupsToGroups :: Int -> [PhyloPeriodId] -> 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 ->
let -- 1) find the parents/childs matching periods let -- 1) find the parents/childs matching periods
periodsPar = getNextPeriods ToParents frame prd periods periodsPar = getNextPeriods ToParents frame prd periods
periodsChi = getNextPeriods ToChilds frame prd periods periodsChi = getNextPeriods ToChilds frame prd periods
-- 2) find the parents/childs matching candidates -- 2) find the parents/childs matching candidates
candidatesPar = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsPar candidatesPar = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsPar
candidatesChi = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsChi candidatesChi = map (\prd' -> map (\g -> (getGroupId g, g ^. phylo_groupNgrams)) $ findWithDefault [] prd' groups') periodsChi
-- 3) find the parents/child number of docs by years -- 3) find the parents/child number of docs by years
docsPar = filterDocs docs ([prd] ++ periodsPar) docsPar = filterDocs docs ([prd] ++ periodsPar)
docsChi = filterDocs docs ([prd] ++ periodsChi) docsChi = filterDocs docs ([prd] ++ periodsChi)
...@@ -270,7 +270,7 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups = ...@@ -270,7 +270,7 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups =
diagoPar = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar) diagoPar = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar)
diagoChi = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar) diagoChi = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar)
-- 5) match in parallel all the groups (egos) to their possible candidates -- 5) match in parallel all the groups (egos) to their possible candidates
egos = map (\ego -> egos = map (\ego ->
let pointersPar = phyloGroupMatching (getCandidates ego candidatesPar) ToParents proximity docsPar diagoPar let pointersPar = phyloGroupMatching (getCandidates ego candidatesPar) ToParents proximity docsPar diagoPar
thr (getPeriodPointers ToParents ego) (getGroupId ego, ego ^. phylo_groupNgrams) thr (getPeriodPointers ToParents ego) (getGroupId ego, ego ^. phylo_groupNgrams)
pointersChi = phyloGroupMatching (getCandidates ego candidatesChi) ToChilds proximity docsChi diagoChi pointersChi = phyloGroupMatching (getCandidates ego candidatesChi) ToChilds proximity docsChi diagoChi
...@@ -280,8 +280,8 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups = ...@@ -280,8 +280,8 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups =
$ addMemoryPointers ToChildsMemory TemporalPointer thr pointersChi $ addMemoryPointers ToChildsMemory TemporalPointer thr pointersChi
$ addMemoryPointers ToParentsMemory TemporalPointer thr pointersPar ego) $ addMemoryPointers ToParentsMemory TemporalPointer thr pointersPar ego)
$ findWithDefault [] prd groups' $ findWithDefault [] prd groups'
egos' = egos `using` parList rdeepseq egos' = egos `using` parList rdeepseq
in acc ++ egos' in acc ++ egos'
) [] periods ) [] periods
...@@ -291,23 +291,23 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups = ...@@ -291,23 +291,23 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups =
relevantBranches :: Int -> [[PhyloGroup]] -> [[PhyloGroup]] relevantBranches :: Int -> [[PhyloGroup]] -> [[PhyloGroup]]
relevantBranches term branches = relevantBranches term branches =
filter (\groups -> (any (\group -> elem term $ group ^. phylo_groupNgrams) groups)) branches filter (\groups -> (any (\group -> elem term $ group ^. phylo_groupNgrams) groups)) branches
accuracy :: Int -> [(Date,Date)] -> [PhyloGroup] -> Double accuracy :: Int -> [(Date,Date)] -> [PhyloGroup] -> Double
-- The accuracy of a branch relatively to a term x is computed only over the periods there exist some cluster mentionning x in the phylomemy -- The accuracy of a branch relatively to a term x is computed only over the periods there exist some cluster mentionning x in the phylomemy
accuracy x periods bk = ((fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk') accuracy x periods bk = ((fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk')
/ (fromIntegral $ length bk')) / (fromIntegral $ length bk'))
where where
bk' :: [PhyloGroup] bk' :: [PhyloGroup]
bk' = filter (\g -> elem (g ^. phylo_groupPeriod) periods) bk bk' = filter (\g -> elem (g ^. phylo_groupPeriod) periods) bk
recall :: Int -> [PhyloGroup] -> [[PhyloGroup]] -> Double recall :: Int -> [PhyloGroup] -> [[PhyloGroup]] -> Double
recall x bk bx = ((fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk) recall x bk bx = ((fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) bk)
/ (fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx)) / (fromIntegral $ length $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx))
fScore :: Double -> Int -> [(Date,Date)] -> [PhyloGroup] -> [[PhyloGroup]] -> Double fScore :: Double -> Int -> [(Date,Date)] -> [PhyloGroup] -> [[PhyloGroup]] -> Double
fScore lambda x periods bk bx = fScore lambda x periods bk bx =
let rec = recall x bk bx let rec = recall x bk bx
acc = accuracy x periods bk acc = accuracy x periods bk
in ((1 + lambda ** 2) * acc * rec) in ((1 + lambda ** 2) * acc * rec)
...@@ -322,65 +322,65 @@ toPhyloQuality' :: Double -> Map Int Double -> [[PhyloGroup]] -> Double ...@@ -322,65 +322,65 @@ toPhyloQuality' :: Double -> Map Int Double -> [[PhyloGroup]] -> Double
toPhyloQuality' lambda freq branches = toPhyloQuality' lambda freq branches =
if (null branches) if (null branches)
then 0 then 0
else sum else sum
$ map (\i -> $ map (\i ->
let bks = relevantBranches i branches let bks = relevantBranches i branches
periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem i $ g ^. phylo_groupNgrams) $ concat bks 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)) in (freq ! i) * (sum $ map (\bk -> ((wk bk) / (sum $ map wk bks)) * (fScore lambda i periods bk bks)) bks))
$ keys freq $ 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)
then 0 then 0
else sum else sum
$ map (\x -> $ map (\x ->
let px = freq ! x let px = freq ! x
bx = relevantBranches x branches bx = relevantBranches x branches
wks = sum $ map wk bx wks = sum $ map wk bx
in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (recall x bk bx)) bx)) in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (recall x bk bx)) bx))
$ keys freq $ keys freq
where where
pys :: Double pys :: Double
pys = sum (elems freq) pys = sum (elems freq)
toAccuracy :: Map Int Double -> [[PhyloGroup]] -> Double toAccuracy :: Map Int Double -> [[PhyloGroup]] -> Double
toAccuracy freq branches = toAccuracy freq branches =
if (null branches) if (null branches)
then 0 then 0
else sum else sum
$ map (\x -> $ map (\x ->
let px = freq ! x let px = freq ! x
bx = relevantBranches x branches bx = relevantBranches x branches
-- | periods containing x -- | periods containing x
periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx
wks = sum $ map wk bx wks = sum $ map wk bx
in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (accuracy x periods bk)) bx)) in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (accuracy x periods bk)) bx))
$ keys freq $ keys freq
where where
pys :: Double pys :: Double
pys = sum (elems freq) pys = sum (elems freq)
-- | here we do the average of all the local f_scores -- | here we do the average of all the local f_scores
toPhyloQuality :: Double -> Double -> Map Int Double -> [[PhyloGroup]] -> Double toPhyloQuality :: Double -> Double -> Map Int Double -> [[PhyloGroup]] -> Double
toPhyloQuality fdt lambda freq branches = toPhyloQuality fdt lambda freq branches =
if (null branches) if (null branches)
then 0 then 0
else sum else sum
$ map (\x -> $ map (\x ->
-- let px = freq ! x -- let px = freq ! x
let bx = relevantBranches x branches let bx = relevantBranches x branches
-- | periods containing x -- | periods containing x
periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx periods = nub $ map _phylo_groupPeriod $ filter (\g -> elem x $ g ^. phylo_groupNgrams) $ concat bx
wks = sum $ map wk bx wks = sum $ map wk bx
-- in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore beta x bk bx)) bx)) -- in (px / pys) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore beta x bk bx)) bx))
-- in (1 / fdt) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore beta x periods bk bx)) bx)) -- in (1 / fdt) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore beta x periods bk bx)) bx))
in (1 / fdt) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore (tan (lambda * pi / 2)) x periods bk bx)) bx)) in (1 / fdt) * (sum $ map (\bk -> ((wk bk) / wks) * (fScore (tan (lambda * pi / 2)) x periods bk bx)) bx))
$ keys freq $ keys freq
-- where -- where
-- pys :: Double -- pys :: Double
-- pys = sum (elems freq) -- pys = sum (elems freq)
-- 1 / nb de foundation -- 1 / nb de foundation
...@@ -395,14 +395,14 @@ groupsToBranches' groups = ...@@ -395,14 +395,14 @@ 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)
$ map (\group -> [getGroupId group] $ map (\group -> [getGroupId group]
++ (map fst $ group ^. phylo_groupPeriodParents) ++ (map fst $ group ^. phylo_groupPeriodParents)
++ (map fst $ group ^. phylo_groupPeriodChilds) ) $ elems groups ++ (map fst $ group ^. phylo_groupPeriodChilds) ) $ elems groups
-- first find the related components by inside each ego's period -- first find the related components by inside each ego's period
-- a supprimer -- a supprimer
graph' = map relatedComponents egos graph' = map relatedComponents egos
-- then run it for the all the periods -- then run it for the all the periods
graph = zip [1..] graph = zip [1..]
$ relatedComponents $ concat (graph' `using` parList rdeepseq) $ relatedComponents $ concat (graph' `using` parList rdeepseq)
-- update each group's branch id -- update each group's branch id
in map (\(bId,ids) -> in map (\(bId,ids) ->
...@@ -412,11 +412,11 @@ groupsToBranches' groups = ...@@ -412,11 +412,11 @@ groupsToBranches' groups =
reduceFrequency :: Map Int Double -> [[PhyloGroup]] -> Map Int Double reduceFrequency :: Map Int Double -> [[PhyloGroup]] -> Map Int Double
reduceFrequency frequency branches = reduceFrequency frequency branches =
restrictKeys frequency (Set.fromList $ (nub . concat) $ map _phylo_groupNgrams $ concat branches) restrictKeys frequency (Set.fromList $ (nub . concat) $ map _phylo_groupNgrams $ concat branches)
updateThr :: Double -> [[PhyloGroup]] -> [[PhyloGroup]] updateThr :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
updateThr thr branches = map (\b -> map (\g -> updateThr thr branches = map (\b -> map (\g ->
g & phylo_groupMeta .~ (singleton "seaLevels" (((g ^. phylo_groupMeta) ! "seaLevels") ++ [thr]))) b) branches g & phylo_groupMeta .~ (singleton "seaLevels" (((g ^. phylo_groupMeta) ! "seaLevels") ++ [thr]))) b) branches
...@@ -424,46 +424,46 @@ updateThr thr branches = map (\b -> map (\g -> ...@@ -424,46 +424,46 @@ updateThr thr branches = map (\b -> map (\g ->
-- done = all the allready broken branches -- done = all the allready broken branches
-- 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 -> [PhyloPeriodId] -> [([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 : "
-- <> " |✓ " <> show(length $ fst ego') <> show(map length $ fst ego') -- <> " |✓ " <> show(length $ fst ego') <> show(map length $ fst ego')
-- <> " |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]") -- <> " |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]")
[(fst ego,False)] [(fst ego,False)]
else else
-- trace (" ✓ level = " <> printf "%.1f" thr <> "") -- trace (" ✓ level = " <> printf "%.1f" thr <> "")
-- trace (" ✓ F(β) = " <> show(quality) <> " (vs) " <> show(quality') -- trace (" ✓ F(β) = " <> show(quality) <> " (vs) " <> show(quality')
-- <> " | " <> show(length $ fst ego) <> " groups : " -- <> " | " <> show(length $ fst ego) <> " groups : "
-- <> " |✓ " <> show(length $ fst ego') <> show(map length $ fst ego') -- <> " |✓ " <> show(length $ fst ego') <> show(map length $ fst ego')
-- <> " |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]") -- <> " |✗ " <> show(length $ snd ego') <> "[" <> show(length $ concat $ snd ego') <> "]")
((map (\e -> (e,True)) (fst ego')) ++ (map (\e -> (e,False)) (snd ego')))) ((map (\e -> (e,True)) (fst ego')) ++ (map (\e -> (e,False)) (snd ego'))))
else [ego]) else [ego])
in in
-- 2) if there is no more branches in rest then return else continue -- 2) if there is no more branches in rest then return else continue
if null rest if null rest
then done' then done'
else breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods else breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods
done' (head' "breakBranches" rest) (tail' "breakBranches" rest) done' (head' "breakBranches" rest) (tail' "breakBranches" rest)
where where
-------------------------------------- --------------------------------------
quality :: Double quality :: Double
quality = toPhyloQuality fdt lambda frequency ((map fst done) ++ [fst ego] ++ (map fst rest)) quality = toPhyloQuality fdt lambda frequency ((map fst done) ++ [fst ego] ++ (map fst rest))
-------------------------------------- --------------------------------------
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)
$ thrToMeta thr $ thrToMeta thr
$ depthToMeta (elevation - depth) branches' $ depthToMeta (elevation - depth) branches'
-------------------------------------- --------------------------------------
quality' :: Double quality' :: Double
quality' = toPhyloQuality fdt lambda frequency quality' = toPhyloQuality fdt lambda frequency
...@@ -476,27 +476,27 @@ seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevati ...@@ -476,27 +476,27 @@ seaLevelMatching fdt proximity lambda minBranch frequency thr step depth elevati
-- 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
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)
acc = toAccuracy frequency (map fst branches) acc = toAccuracy frequency (map fst branches)
rec = toRecall frequency (map fst branches) rec = toRecall frequency (map fst branches)
branches' = trace ("↑ level = " <> printf "%.3f" thr <> " F(λ) = " <> printf "%.5f" quality branches' = trace ("↑ level = " <> printf "%.3f" thr <> " F(λ) = " <> printf "%.5f" quality
<> " ξ = " <> printf "%.5f" acc <> " ξ = " <> printf "%.5f" acc
<> " ρ = " <> printf "%.5f" rec <> " ρ = " <> printf "%.5f" rec
<> " branches = " <> show(length branches) <> " ↴") <> " branches = " <> show(length branches) <> " ↴")
$ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods $ breakBranches fdt proximity lambda frequency minBranch thr depth elevation frame docs coocs periods
[] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches) [] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches)
frequency' = reduceFrequency frequency (map fst branches') frequency' = reduceFrequency frequency (map fst branches')
in seaLevelMatching fdt proximity lambda minBranch frequency' (thr + step) step (depth - 1) elevation frame periods docs coocs branches' in seaLevelMatching fdt proximity lambda minBranch frequency' (thr + step) step (depth - 1) elevation frame periods docs coocs branches'
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 branches)
(toPhyloHorizon phylo) (toPhyloHorizon phylo)
where where
-- 2) process the temporal matching by elevating seaLvl level -- 2) process the temporal matching by elevating seaLvl level
branches :: [[PhyloGroup]] branches :: [[PhyloGroup]]
branches = map fst branches = map fst
$ seaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo) $ seaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo)
...@@ -511,16 +511,16 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1 ...@@ -511,16 +511,16 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
(getPeriodIds phylo) (getPeriodIds phylo)
(phylo ^. phylo_timeDocs) (phylo ^. phylo_timeDocs)
(phylo ^. phylo_timeCooc) (phylo ^. phylo_timeCooc)
(reverse $ sortOn (length . fst) groups) (reverse $ sortOn (length . fst) groups)
-- 1) for each group process an initial temporal Matching -- 1) for each group process an initial temporal Matching
-- 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
(phylo ^. phylo_timeDocs) (phylo ^. phylo_timeDocs)
(phylo ^. phylo_timeCooc) (phylo ^. phylo_timeCooc)
(traceTemporalMatching $ getGroupsFromLevel 1 phylo) (traceTemporalMatching $ getGroupsFromLevel 1 phylo)
...@@ -528,16 +528,16 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1 ...@@ -528,16 +528,16 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
-- | Horizon | -- -- | Horizon | --
----------------- -----------------
toPhyloHorizon :: Phylo -> Phylo toPhyloHorizon :: Phylo -> Phylo
toPhyloHorizon phylo = toPhyloHorizon phylo =
let t0 = take 1 (getPeriodIds phylo) let t0 = take 1 (getPeriodIds phylo)
groups = getGroupsFromLevelPeriods 1 t0 phylo groups = getGroupsFromLevelPeriods 1 t0 phylo
sens = getSensibility (phyloProximity $ getConfig phylo) sens = getSensibility (phyloProximity $ getConfig phylo)
nbDocs = sum $ elems $ filterDocs (phylo ^. phylo_timeDocs) t0 nbDocs = sum $ elems $ filterDocs (phylo ^. phylo_timeDocs) t0
diago = reduceDiagos $ filterDiago (phylo ^. phylo_timeCooc) t0 diago = reduceDiagos $ filterDiago (phylo ^. phylo_timeCooc) t0
in phylo & phylo_horizon .~ (fromList $ map (\(g,g') -> in phylo & phylo_horizon .~ (fromList $ map (\(g,g') ->
((getGroupId g,getGroupId g'),weightedLogJaccard' sens nbDocs diago (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) $ listToCombi' groups) ((getGroupId g,getGroupId g'),weightedLogJaccard' sens nbDocs diago (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) $ listToCombi' groups)
-------------------------------------- --------------------------------------
-- | Adaptative Temporal Matching | -- -- | Adaptative Temporal Matching | --
...@@ -545,15 +545,15 @@ toPhyloHorizon phylo = ...@@ -545,15 +545,15 @@ toPhyloHorizon phylo =
thrToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]] thrToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
thrToMeta thr branches = thrToMeta thr branches =
map (\b -> map (\b ->
map (\g -> g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [thr]) "seaLevels" (g ^. phylo_groupMeta))) b) branches map (\g -> g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [thr]) "seaLevels" (g ^. phylo_groupMeta))) b) branches
depthToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]] depthToMeta :: Double -> [[PhyloGroup]] -> [[PhyloGroup]]
depthToMeta depth branches = depthToMeta depth branches =
let break = length branches > 1 let break = length branches > 1
in map (\b -> in map (\b ->
map (\g -> map (\g ->
if break then g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [depth]) "breaks"(g ^. phylo_groupMeta)) if break then g & phylo_groupMeta .~ (adjust (\lst -> lst ++ [depth]) "breaks"(g ^. phylo_groupMeta))
else g) b) branches else g) b) branches
...@@ -569,67 +569,67 @@ getInTupleMap m k k' ...@@ -569,67 +569,67 @@ getInTupleMap m k k'
toThreshold :: Double -> Map (PhyloGroupId,PhyloGroupId) Double -> Double toThreshold :: Double -> Map (PhyloGroupId,PhyloGroupId) Double -> Double
toThreshold lvl proxiGroups = toThreshold lvl proxiGroups =
let idx = ((Map.size proxiGroups) `div` (floor lvl)) - 1 let idx = ((Map.size proxiGroups) `div` (floor lvl)) - 1
in if idx >= 0 in if idx >= 0
then (sort $ elems proxiGroups) !! idx then (sort $ elems proxiGroups) !! idx
else 1 else 1
-- done = all the allready broken branches -- done = all the allready broken branches
-- 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
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]))] -> [PhyloPeriodId] -> [([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
let done' = done ++ (if (fst . snd) ego let done' = done ++ (if (fst . snd) ego
then (if ((null (fst ego')) || (quality > quality')) then (if ((null (fst ego')) || (quality > quality'))
then then
[(concat $ thrToMeta thr $ [fst ego],(False, ((snd . snd) ego)))] [(concat $ thrToMeta thr $ [fst ego],(False, ((snd . snd) ego)))]
else else
( (map (\e -> (e,(True, ((snd . snd) ego) ++ [thr]))) (fst ego')) ( (map (\e -> (e,(True, ((snd . snd) ego) ++ [thr]))) (fst ego'))
++ (map (\e -> (e,(False, ((snd . snd) ego)))) (snd ego')))) ++ (map (\e -> (e,(False, ((snd . snd) ego)))) (snd ego'))))
else [(concat $ thrToMeta thr $ [fst ego], snd ego)]) else [(concat $ thrToMeta thr $ [fst ego], snd ego)])
in in
-- uncomment let .. in for debugging -- uncomment let .. in for debugging
-- let part1 = partition (snd) done' -- let part1 = partition (snd) done'
-- part2 = partition (snd) rest -- part2 = partition (snd) rest
-- in trace ( "[✓ " <> show(length $ fst part1) <> "(" <> show(length $ concat $ map (fst) $ fst part1) <> ")|✗ " <> show(length $ snd part1) <> "(" <> show(length $ concat $ map (fst) $ snd part1) <> ")] " -- in trace ( "[✓ " <> show(length $ fst part1) <> "(" <> show(length $ concat $ map (fst) $ fst part1) <> ")|✗ " <> show(length $ snd part1) <> "(" <> show(length $ concat $ map (fst) $ snd part1) <> ")] "
-- <> "[✓ " <> show(length $ fst part2) <> "(" <> show(length $ concat $ map (fst) $ fst part2) <> ")|✗ " <> show(length $ snd part2) <> "(" <> show(length $ concat $ map (fst) $ snd part2) <> ")]" -- <> "[✓ " <> show(length $ fst part2) <> "(" <> show(length $ concat $ map (fst) $ fst part2) <> ")|✗ " <> show(length $ snd part2) <> "(" <> show(length $ concat $ map (fst) $ snd part2) <> ")]"
-- ) $ -- ) $
-- 2) if there is no more branches in rest then return else continue -- 2) if there is no more branches in rest then return else continue
if null rest if null rest
then done' then done'
else adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods else adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods
done' (head' "breakBranches" rest) (tail' "breakBranches" rest) done' (head' "breakBranches" rest) (tail' "breakBranches" rest)
where where
-------------------------------------- --------------------------------------
thr :: Double thr :: Double
thr = toThreshold depth $ Map.filter (\v -> v > (last' "breakBranches" $ (snd . snd) ego)) $ reduceTupleMapByKeys (map getGroupId $ fst ego) groupsProxi thr = toThreshold depth $ Map.filter (\v -> v > (last' "breakBranches" $ (snd . snd) ego)) $ reduceTupleMapByKeys (map getGroupId $ fst ego) groupsProxi
-------------------------------------- --------------------------------------
quality :: Double quality :: Double
quality = toPhyloQuality fdt lambda frequency ((map fst done) ++ [fst ego] ++ (map fst rest)) quality = toPhyloQuality fdt lambda frequency ((map fst done) ++ [fst ego] ++ (map fst rest))
-------------------------------------- --------------------------------------
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)
$ thrToMeta thr $ thrToMeta thr
$ depthToMeta (elevation - depth) branches' $ depthToMeta (elevation - depth) branches'
-------------------------------------- --------------------------------------
quality' :: Double quality' :: Double
quality' = toPhyloQuality fdt lambda frequency quality' = toPhyloQuality fdt lambda frequency
((map fst done) ++ (fst ego') ++ (snd ego') ++ (map fst rest)) ((map fst done) ++ (fst ego') ++ (snd ego') ++ (map fst rest))
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 -> [PhyloPeriodId] -> 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
...@@ -637,7 +637,7 @@ adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minB ...@@ -637,7 +637,7 @@ adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minB
then branches then branches
else else
-- break all the possible branches at the current seaLvl level -- break all the possible branches at the current seaLvl level
let branches' = adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods let branches' = adaptativeBreakBranches fdt proxiConf depth elevation groupsProxi lambda frequency minBranch frame docs coocs periods
[] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches) [] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches)
frequency' = reduceFrequency frequency (map fst branches') frequency' = reduceFrequency frequency (map fst branches')
groupsProxi' = reduceTupleMapByKeys (map (getGroupId) $ concat $ map (fst) $ filter (fst . snd) branches') groupsProxi groupsProxi' = reduceTupleMapByKeys (map (getGroupId) $ concat $ map (fst) $ filter (fst . snd) branches') groupsProxi
...@@ -649,12 +649,12 @@ adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minB ...@@ -649,12 +649,12 @@ adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minB
$ adaptativeSeaLevelMatching fdt proxiConf (depth - 1) elevation groupsProxi' lambda minBranch frequency' frame periods docs coocs branches' $ adaptativeSeaLevelMatching fdt proxiConf (depth - 1) elevation groupsProxi' lambda minBranch frequency' frame periods docs coocs branches'
adaptativeTemporalMatching :: Double -> Phylo -> Phylo adaptativeTemporalMatching :: Double -> Phylo -> Phylo
adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1 adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
(fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches) (fromList $ map (\g -> (getGroupId g,g)) $ traceMatchEnd $ concat branches)
(toPhyloHorizon phylo) (toPhyloHorizon phylo)
where where
-- 2) process the temporal matching by elevating seaLvl level -- 2) process the temporal matching by elevating seaLvl level
branches :: [[PhyloGroup]] branches :: [[PhyloGroup]]
branches = map fst branches = map fst
$ adaptativeSeaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo) $ adaptativeSeaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo)
...@@ -669,16 +669,16 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1 ...@@ -669,16 +669,16 @@ adaptativeTemporalMatching elevation phylo = updatePhyloGroups 1
(getPeriodIds phylo) (getPeriodIds phylo)
(phylo ^. phylo_timeDocs) (phylo ^. phylo_timeDocs)
(phylo ^. phylo_timeCooc) (phylo ^. phylo_timeCooc)
groups groups
-- 1) for each group process an initial temporal Matching -- 1) for each group process an initial temporal Matching
-- 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
(phylo ^. phylo_timeDocs) (phylo ^. phylo_timeDocs)
(phylo ^. phylo_timeCooc) (phylo ^. phylo_timeCooc)
(traceTemporalMatching $ getGroupsFromLevel 1 phylo) (traceTemporalMatching $ getGroupsFromLevel 1 phylo)
-------------------------------------- --------------------------------------
......
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