Skip to content

haskell-gargantext
haskell-gargantext
Commit 7832afe9 authored by qlobbe's avatar qlobbe
Browse files
Options

fix the diagonal issue

parent 7550f605
Pipeline #433 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 136 additions and 66 deletions
    bin/gargantext-phylo/Main.hs
    View file @ 7832afe9
    ......@@ -80,6 +80,8 @@ data Conf =
    , timeFrame :: Int
    , timeTh :: Double
    , timeSens :: Double
    , reBranchThr :: Double
    , reBranchNth :: Int
    , clusterTh :: Double
    , clusterSens :: Double
    , phyloLevel :: Int
    ......@@ -208,7 +210,8 @@ main = do
    let mFis = DM.fromListWith (++) $ DL.sortOn (fst . fst) $ map (\f -> (getFisPeriod f,[f])) fis
    let query = PhyloQueryBuild (phyloName conf) "" (timeGrain conf) (timeStep conf)
    (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (timeFrame conf) (phyloLevel conf)
    (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (timeFrame conf)
    (reBranchThr conf) (reBranchNth conf) (phyloLevel conf)
    (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams (clusterTh conf) (clusterSens conf))
    let queryView = PhyloQueryView (viewLevel conf) Merge False 1 [BranchAge] [SizeBranch $ SBParams (minSizeBranch conf)] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
    ......
    src/Gargantext/Viz/Phylo.hs
    View file @ 7832afe9
    ......@@ -349,6 +349,9 @@ data PhyloQueryBuild = PhyloQueryBuild
    , _q_interTemporalMatching :: Proximity
    , _q_interTemporalMatchingFrame :: Int
    , _q_reBranchThr :: Double
    , _q_reBranchNth :: Int
    -- Last level of reconstruction
    , _q_nthLevel :: Level
    -- Clustering method used from level 1 to nthLevel
    ......
    src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs
    View file @ 7832afe9
    ......@@ -51,7 +51,7 @@ graphToClusters clust (nodes,edges) = case clust of
    -- | To transform a list of PhyloGroups into a Graph of Proximity
    groupsToGraph :: Double -> Proximity -> [PhyloGroup] -> ([GroupNode],[GroupEdge])
    groupsToGraph nbDocs prox gs = case prox of
    WeightedLogJaccard (WLJParams _ sens) -> (gs, map (\(x,y) -> ((x,y), weightedLogJaccard sens (getGroupCooc x) (getGroupCooc y) nbDocs))
    WeightedLogJaccard (WLJParams _ sens) -> (gs, map (\(x,y) -> ((x,y), weightedLogJaccard sens nbDocs (getGroupCooc x) (getGroupCooc y) (getGroupNgrams x) (getGroupNgrams y)))
    $ getCandidates gs)
    Hamming (HammingParams _) -> (gs, map (\(x,y) -> ((x,y), hamming (getGroupCooc x) (getGroupCooc y))) $ getCandidates gs)
    _ -> undefined
    ......
    src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs
    View file @ 7832afe9
    ......@@ -17,7 +17,7 @@ Portability : POSIX
    module Gargantext.Viz.Phylo.Aggregates.Cooc
    where
    import Data.List (union,concat,nub,sort)
    import Data.List (union,concat,nub,sort, sortOn)
    import Data.Map (Map,elems,adjust,filterWithKey,fromListWith,fromList,restrictKeys)
    import Data.Set (Set)
    import Data.Vector (Vector)
    ......@@ -27,6 +27,7 @@ import Gargantext.Viz.Phylo.Tools
    import qualified Data.Map as Map
    import qualified Data.Set as Set
    -- import Debug.Trace (trace)
    -- | To transform the Fis into a full coocurency Matrix in a Phylo
    fisToCooc :: Map (Date, Date) [PhyloFis] -> Phylo -> Map (Int, Int) Double
    ......@@ -120,6 +121,13 @@ unionOfCooc :: PhyloGroup -> PhyloGroup -> Phylo -> Map (Int,Int) Double
    unionOfCooc g g' p = sumCooc (groupToCooc g p) (groupToCooc g' p)
    -- | To get the nth most occurent elems in a coocurency matrix
    getNthMostOcc :: Int -> Map (Int,Int) Double -> [Int]
    getNthMostOcc nth cooc = (nub . concat)
    $ map (\((idx,idx'),_) -> [idx,idx'])
    $ take nth
    $ reverse
    $ sortOn snd $ Map.toList cooc
    -- phyloCooc :: Map (Int, Int) Double
    ......
    src/Gargantext/Viz/Phylo/BranchMaker.hs
    View file @ 7832afe9
    ......@@ -47,20 +47,13 @@ getGroupsNgrams :: [PhyloGroup] -> [Int]
    getGroupsNgrams gs = (sort . nub . concat) $ map getGroupNgrams gs
    getNthMostOcc :: Int -> Map (Int,Int) Double -> [Int]
    getNthMostOcc nth cooc = (nub . concat)
    $ map (\((idx,idx'),_) -> [idx,idx'])
    $ take (nth `div` 2)
    $ reverse
    $ sortOn snd $ Map.toList cooc
    -- | Get the Nth most coocurent Ngrams in a list of Groups
    getGroupsPeaks :: [PhyloGroup] -> Int -> Phylo -> [Int]
    getGroupsPeaks gs nth p = getNthMostOcc nth
    $ getSubCooc (getGroupsNgrams gs)
    $ getCooc (getGroupsPeriods gs) p
    areDistant :: (Date,Date) -> (Date,Date) -> Int -> Bool
    areDistant prd prd' thr = (((fst prd') - (snd prd)) > thr) || (((fst prd) - (snd prd')) > thr)
    ......@@ -107,7 +100,7 @@ makeBranchLinks p prox (id,gs) bs pts
    pts' = concat $ map (\(_id,gs') -> findBestPointer p prox gs gs') candidates
    --------------------------------------
    candidates :: [(PhyloBranchId,[PhyloGroup])]
    candidates = findSimBranches (getPhyloMatchingFrame p) 0.9 4 p (id,gs) bs
    candidates = findSimBranches (getPhyloMatchingFrame p) (getPhyloReBranchThr p) (getPhyloReBranchNth p) p (id,gs) bs
    ......
    src/Gargantext/Viz/Phylo/Example.hs
    View file @ 7832afe9
    ......@@ -105,7 +105,7 @@ queryEx = "title=Cesar et Cleôpatre"
    phyloQueryBuild :: PhyloQueryBuild
    phyloQueryBuild = PhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
    5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.1 20) 5 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.3 0)
    5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.1 20) 5 0.5 4 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.3 0)
    ......
    src/Gargantext/Viz/Phylo/LevelMaker.hs
    View file @ 7832afe9
    ......@@ -128,8 +128,7 @@ cliqueToGroup prd lvl idx lbl fis p =
    -- | To transform a list of Ngrams into a PhyloGroup
    ngramsToGroup :: PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
    ngramsToGroup prd lvl idx lbl ngrams p =
    PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInRoots x p) ngrams) empty Nothing
    ngramsToGroup prd lvl idx lbl ngrams p = PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInRoots x p) ngrams) empty Nothing
    (getMiniCooc (listToFullCombi $ sort $ map (\x -> getIdxInRoots x p) ngrams) (periodsToYears [prd]) (getPhyloCooc p))
    [] [] [] []
    ......@@ -141,7 +140,7 @@ toPhyloLevel lvl m p = alterPhyloPeriods
    in over (phylo_periodLevels)
    (\phyloLevels ->
    let groups = toPhyloGroups lvl pId (m ! pId) m p
    in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
    in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
    ) period) p
    ......
    src/Gargantext/Viz/Phylo/LinkMaker.hs
    View file @ 7832afe9
    ......@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.LinkMaker
    where
    import Control.Lens hiding (both, Level)
    import Data.List ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete, intersect, nub, groupBy)
    import Data.List ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete, intersect, nub, groupBy, union)
    import Data.Tuple.Extra
    import Data.Map (Map,(!),fromListWith,elems,restrictKeys,unionWith,member)
    import Gargantext.Prelude
    ......@@ -108,9 +108,9 @@ periodsToNbDocs prds phylo = sum $ elems
    -- | To process a given Proximity
    processProximity :: Proximity -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
    processProximity proximity cooc cooc' nbDocs = case proximity of
    WeightedLogJaccard (WLJParams _ sens) -> weightedLogJaccard sens cooc cooc' nbDocs
    processProximity :: Proximity -> Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> [Int] -> [Int] -> Double
    processProximity proximity nbDocs cooc cooc' ngrams ngrams' = case proximity of
    WeightedLogJaccard (WLJParams _ sens) -> weightedLogJaccard sens nbDocs cooc cooc' ngrams ngrams'
    Hamming (HammingParams _) -> hamming cooc cooc'
    _ -> panic "[ERR][Viz.Phylo.LinkMaker.processProximity] Unknown proximity"
    ......@@ -136,17 +136,20 @@ findBestCandidates filiation depth limit proximity periods candidates g1 phylo
    ) similarities
    --------------------------------------
    similarities :: [(PhyloGroupId, Double)]
    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
    cooc2 = getGroupCooc g2
    cooc3 = getGroupCooc g3
    score = processProximity proximity cooc1 (unionWith (+) cooc2 cooc3) nbDocs
    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
    cooc' = unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
    ngrams' = union (getGroupNgrams g2) (getGroupNgrams g3)
    score = processProximity proximity nbDocs cooc cooc' ngrams ngrams'
    in nub $ [(getGroupId g2,score),(getGroupId g3,score)]) pairsOfCandidates
    --------------------------------------
    pairsOfCandidates :: [(PhyloGroup,PhyloGroup)]
    pairsOfCandidates = listToFullCombi $ filter (\g -> elem (getGroupPeriod g) nextPeriods) candidates
    --------------------------------------
    cooc1 :: Map (Int,Int) Double
    cooc1 = getGroupCooc g1
    cooc :: Map (Int,Int) Double
    cooc = getGroupCooc g1
    --------------------------------------
    ngrams :: [Int]
    ngrams = getGroupNgrams g1
    --------------------------------------
    nextPeriods :: [(Date,Date)]
    nextPeriods = take depth periods
    ......@@ -159,23 +162,27 @@ findBestCandidates' proximity candidates g1 phylo = pointers
    --------------------------------------
    pointers :: [(PhyloGroupId, Double)]
    pointers = reverse $ sortOn snd $ filter (\(_,score) -> case proximity of
    WeightedLogJaccard (WLJParams thr _) -> score >= thr
    WeightedLogJaccard (WLJParams thr _) -> score >= (thr - 0.1)
    Hamming (HammingParams thr) -> score <= thr
    _ -> panic "[ERR][Viz.Phylo.LinkMaker.findBestCandidates'] Unknown proximity"
    ) similarities
    --------------------------------------
    similarities :: [(PhyloGroupId, Double)]
    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
    cooc2 = getGroupCooc g2
    cooc3 = getGroupCooc g3
    score = processProximity proximity cooc1 (unionWith (+) cooc2 cooc3) nbDocs
    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
    cooc' = unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
    ngrams' = union (getGroupNgrams g2) (getGroupNgrams g3)
    score = processProximity proximity nbDocs cooc cooc' ngrams ngrams'
    in nub $ [(getGroupId g2,score),(getGroupId g3,score)]) pairsOfCandidates
    --------------------------------------
    pairsOfCandidates :: [(PhyloGroup,PhyloGroup)]
    pairsOfCandidates = listToFullCombi candidates
    --------------------------------------
    cooc1 :: Map (Int,Int) Double
    cooc1 = getGroupCooc g1
    --------------------------------------
    cooc :: Map (Int,Int) Double
    cooc = getGroupCooc g1
    --------------------------------------
    ngrams :: [Int]
    ngrams = getGroupNgrams g1
    --------------------------------------
    ......
    src/Gargantext/Viz/Phylo/Metrics/Proximity.hs
    View file @ 7832afe9
    ......@@ -17,8 +17,8 @@ Portability : POSIX
    module Gargantext.Viz.Phylo.Metrics.Proximity
    where
    import Data.List (null)
    import Data.Map (Map,elems,unionWith,intersectionWith,intersection,size,keys)
    import Data.List (null,union,intersect)
    import Data.Map (Map,elems,unionWith,intersectionWith,intersection,size,filterWithKey)
    import Gargantext.Prelude
    -- import Debug.Trace (trace)
    ......@@ -29,28 +29,69 @@ sumLog :: Double -> [Double] -> Double
    sumLog s l = foldl (\mem x -> mem + log (s + x)) 0 l
    -- -- | To process WeighedLogJaccard distance between to coocurency matrix
    -- weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
    -- weightedLogJaccard sens cooc cooc' nbDocs
    -- | null union' = 0
    -- | union' == inter' = 1
    -- | sens == 0 = (fromIntegral $ length $ keysInter) / (fromIntegral $ length $ keysUnion)
    -- | sens > 0 = (sumInvLog sens $ elems wInter) / (sumInvLog sens $ elems wUnion)
    -- | otherwise = (sumLog sens $ elems wInter) / (sumLog sens $ elems wUnion)
    -- where
    -- --------------------------------------
    -- keysInter :: [Int]
    -- keysInter = nub $ concat $ map (\(x,x') -> [x,x']) $ keys inter'
    -- --------------------------------------
    -- keysUnion :: [Int]
    -- keysUnion = nub $ concat $ map (\(x,x') -> [x,x']) $ keys union'
    -- --------------------------------------
    -- wInter :: Map (Int,Int) Double
    -- wInter = map (/nbDocs) inter'
    -- --------------------------------------
    -- wUnion :: Map (Int,Int) Double
    -- wUnion = map (/nbDocs) union'
    -- --------------------------------------
    -- inter' :: Map (Int, Int) Double
    -- inter' = intersectionWith (+) cooc cooc'
    -- --------------------------------------
    -- union' :: Map (Int, Int) Double
    -- union' = unionWith (+) cooc cooc'
    -- --------------------------------------
    -- | To compute a jaccard similarity between two lists
    jaccard :: [Int] -> [Int] -> Double
    jaccard inter' union' = ((fromIntegral . length) $ inter') / ((fromIntegral . length) $ union')
    -- | To get the diagonal of a matrix
    toDiago :: Map (Int, Int) Double -> [Double]
    toDiago cooc = elems $ filterWithKey (\(x,x') _ -> x == x') cooc
    -- | To process WeighedLogJaccard distance between to coocurency matrix
    weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
    weightedLogJaccard sens cooc cooc' nbDocs
    | null union' = 0
    | union' == inter' = 1
    | sens == 0 = (fromIntegral $ length $ keys inter') / (fromIntegral $ length $ keys union')
    | sens > 0 = (sumInvLog sens $ elems wInter) / (sumInvLog sens $ elems wUnion)
    | otherwise = (sumLog sens $ elems wInter) / (sumLog sens $ elems wUnion)
    weightedLogJaccard :: Double -> Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> [Int] -> [Int] -> Double
    weightedLogJaccard sens nbDocs cooc cooc' ngrams ngrams'
    | null gInter = 0
    | gInter == gUnion = 1
    | sens == 0 = jaccard gInter gUnion
    | sens > 0 = (sumInvLog sens wInter) / (sumInvLog sens wUnion)
    | otherwise = (sumLog sens wInter) / (sumLog sens wUnion)
    where
    --------------------------------------
    wInter :: Map (Int,Int) Double
    wInter = map (/nbDocs) inter'
    gInter :: [Int]
    gInter = intersect ngrams ngrams'
    --------------------------------------
    wUnion :: Map (Int,Int) Double
    wUnion = map (/nbDocs) union'
    gUnion :: [Int]
    gUnion = union ngrams ngrams'
    --------------------------------------
    inter' :: Map (Int, Int) Double
    inter' = intersectionWith (+) cooc cooc'
    --------------------------------------
    union' :: Map (Int, Int) Double
    union' = unionWith (+) cooc cooc'
    wInter :: [Double]
    wInter = toDiago $ map (/nbDocs) $ intersectionWith (+) cooc cooc'
    --------------------------------------
    wUnion :: [Double]
    wUnion = toDiago $ map (/nbDocs) $ unionWith (+) cooc cooc'
    --------------------------------------
    -- | To process the Hamming distance between two PhyloGroup fields
    ......
    src/Gargantext/Viz/Phylo/Tools.hs
    View file @ 7832afe9
    ......@@ -195,6 +195,12 @@ getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
    getPhyloMatchingFrame :: Phylo -> Int
    getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
    getPhyloReBranchThr :: Phylo -> Double
    getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
    getPhyloReBranchNth :: Phylo -> Int
    getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
    getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
    getPhyloFis = _phylo_fis
    ......@@ -471,7 +477,8 @@ initPhyloPeriod id l = PhyloPeriod id l
    -- | To transform a list of periods into a set of Dates
    periodsToYears :: [(Date,Date)] -> Set Date
    periodsToYears periods = (Set.fromList . sort . concat) [[d,d'] | (d,d') <- periods]
    periodsToYears periods = (Set.fromList . sort . concat)
    $ map (\(d,d') -> [d..d']) periods
    --------------------
    ......@@ -793,11 +800,10 @@ initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
    -- | To initialize a PhyloQueryBuild from given and default parameters
    initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Int -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
    initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Int -> Maybe Double -> Maybe Int -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
    initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
    (def defaultWeightedLogJaccard -> matching') (def 5 -> frame) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
    PhyloQueryBuild name desc grain steps cluster metrics filters matching' frame nthLevel nthCluster
    (def defaultWeightedLogJaccard -> matching') (def 5 -> frame) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
    PhyloQueryBuild name desc grain steps cluster metrics filters matching' frame reBranchThr reBranchNth nthLevel nthCluster
    -- | To initialize a PhyloQueryView default parameters
    ......@@ -850,7 +856,7 @@ defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing N
    defaultQueryBuild :: PhyloQueryBuild
    defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
    Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
    defaultQueryView :: PhyloQueryView
    defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
    ......
    src/Gargantext/Viz/Phylo/View/Export.hs
    View file @ 7832afe9
    ......@@ -157,7 +157,9 @@ setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
    -- | To set an Edge
    setDotEdge :: PhyloEdge -> Dot DotId
    setDotEdge pe = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
    setDotEdge pe
    | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Red]]
    | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target) [Width 2, Color [toWColor Black]]
    -- | To set a Period Edge
    ......
    src/Gargantext/Viz/Phylo/View/Taggers.hs
    View file @ 7832afe9
    ......@@ -26,8 +26,9 @@ import Data.Map (Map)
    import Gargantext.Prelude
    import Gargantext.Viz.Phylo
    import Gargantext.Viz.Phylo.Tools
    import Gargantext.Viz.Phylo.Aggregates.Cooc
    import Gargantext.Viz.Phylo.BranchMaker
    import qualified Data.Map as Map
    -- import Debug.Trace (trace)
    -- | To get the nth most frequent Ngrams in a list of PhyloGroups
    ......@@ -48,14 +49,15 @@ freqToLabel thr ngs l = ngramsToLabel ngs $ mostFreqNgrams thr l
    -- | To get the (nth `div` 2) most cooccuring Ngrams in a PhyloGroup
    mostOccNgrams :: Int -> Phylo -> PhyloGroup -> [Int]
    mostOccNgrams thr p g = (nub . concat )
    $ map (\((f,s),_d) -> [f,s])
    $ take (thr `div` 2)
    $ reverse $ sortOn snd $ Map.toList cooc
    mostOccNgrams :: Int -> PhyloGroup -> [Int]
    mostOccNgrams nth g = (nub . concat)
    $ map (\((f,s),_d) -> [f,s])
    $ take nth
    $ reverse $ sortOn snd
    $ Map.toList cooc
    where
    cooc :: Map (Int, Int) Double
    cooc = getSubCooc (getGroupNgrams g) $ getCooc [getGroupPeriod g] p
    cooc = getGroupCooc g
    -- | To alter the peak of a PhyloBranch
    ......@@ -74,13 +76,18 @@ branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
    $ getGroupsFromNodes ns p))
    $ getNodesByBranches v
    branchPeakCooc :: PhyloView -> Int -> Phylo -> PhyloView
    branchPeakCooc v nth p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
    $ map (\(id,ns) -> (id, ngramsToLabel (getFoundationsRoots p) (getGroupsPeaks (getGroupsFromNodes ns p) nth p) ) )
    $ getNodesByBranches v
    -- | To set the label of a PhyloNode as the nth most coocurent terms of its PhyloNodes
    nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
    nodeLabelCooc v thr p = over (pv_nodes
    . traverse)
    (\n -> let lbl = ngramsToLabel (getFoundationsRoots p)
    $ mostOccNgrams thr p
    $ mostOccNgrams thr
    $ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
    in n & pn_label .~ lbl) v
    ......@@ -89,6 +96,7 @@ nodeLabelCooc v thr p = over (pv_nodes
    processTaggers :: [Tagger] -> Phylo -> PhyloView -> PhyloView
    processTaggers ts p v = foldl (\v' t -> case t of
    BranchPeakFreq -> branchPeakFreq v' 2 p
    -- BranchPeakFreq -> branchPeakCooc v' 3 p
    GroupLabelCooc -> nodeLabelCooc v' 2 p
    _ -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts
    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