Skip to content

haskell-gargantext
haskell-gargantext
Commit 9e5a1b2f authored by qlobbe's avatar qlobbe
Browse files
Options

correct bugs when double pointers

parent 0eb25a50
Pipeline #925 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 23 additions and 16 deletions
    src/Gargantext/Viz/Phylo/TemporalMatching.hs
    View file @ 9e5a1b2f
    ...@@ -15,7 +15,7 @@ Portability : POSIX ...@@ -15,7 +15,7 @@ Portability : POSIX
    module Gargantext.Viz.Phylo.TemporalMatching where module Gargantext.Viz.Phylo.TemporalMatching where
    import Data.List (concat, splitAt, tail, sortOn, (++), intersect, null, inits, groupBy, scanl, nub, union, dropWhile, partition, or, sort, (!!)) import Data.List (concat, splitAt, tail, sortOn, (++), 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 Gargantext.Prelude import Gargantext.Prelude
    ...@@ -139,18 +139,25 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d ...@@ -139,18 +139,25 @@ makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs d
    filterPointers :: Proximity -> Double -> [Pointer] -> [Pointer] filterPointers :: Proximity -> Double -> [Pointer] -> [Pointer]
    filterPointers proxi thr pts = filter (\(_,w) -> filterProximity proxi thr w) pts filterPointers proxi thr pts = filter (\(_,w) -> filterProximity proxi thr w) pts
    filterPointers' :: Proximity -> Double -> [(Pointer,[Int])] -> [(Pointer,[Int])]
    filterPointers' proxi thr pts = filter (\((_,w),_) -> filterProximity proxi thr w) pts
    reduceDiagos :: Map Date Cooc -> Map Int Double reduceDiagos :: Map Date Cooc -> Map Int Double
    reduceDiagos diagos = mapKeys (\(k,_) -> k) reduceDiagos diagos = mapKeys (\(k,_) -> k)
    $ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos) $ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos)
    filterPointersByPeriod :: [Pointer] -> [Pointer] filterPointersByPeriod :: Filiation -> [(Pointer,[Int])] -> [Pointer]
    filterPointersByPeriod pts = filterPointersByPeriod fil pts =
    let pts' = sortOn (fst . fst . fst) pts let pts' = sortOn (fst . fst . fst . fst) pts
    inf = (fst . fst . fst) $ head' "filterPointersByPeriod" pts' inf = (fst . fst . fst . fst) $ head' "filterPointersByPeriod" pts'
    sup = (fst . fst . fst) $ last' "filterPointersByPeriod" pts' sup = (fst . fst . fst . fst) $ last' "filterPointersByPeriod" pts'
    in nub in map fst
    $ filter (\pt -> ((fst . fst . fst) pt == inf) || ((fst . fst . fst) pt == sup)) pts' $ nubBy (\pt pt' -> snd pt == snd pt')
    $ filter (\pt -> ((fst . fst . fst . fst) pt == inf) || ((fst . fst . fst . fst) pt == sup))
    $ case fil of
    ToParents -> reverse pts'
    ToChilds -> 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]
    ...@@ -159,15 +166,15 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -159,15 +166,15 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
    -- | let's find new pointers -- | let's find new pointers
    then if null nextPointers then if null nextPointers
    then [] then []
    else filterPointersByPeriod else filterPointersByPeriod fil
    $ 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 pt == snd pt') $ groupBy (\pt pt' -> (snd . fst) pt == (snd . fst) pt')
    $ reverse $ sortOn snd $ head' "pointers" nextPointers $ reverse $ sortOn (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
    nextPointers :: [[Pointer]] nextPointers :: [[(Pointer,[Int])]]
    nextPointers = take 1 nextPointers = take 1
    $ dropWhile (null) $ dropWhile (null)
    -- | for each time frame, process the proximity on relevant pairs of targeted groups -- | for each time frame, process the proximity on relevant pairs of targeted groups
    ...@@ -178,14 +185,14 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -178,14 +185,14 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
    $ 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') in if ((c == c') || (snd c == snd c'))
    then [(fst c,proximity)] then [((fst c,proximity),snd c)]
    else [(fst c,proximity),(fst c',proximity)] ) 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],...]
    ......
    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