Skip to content

haskell-gargantext
haskell-gargantext
Commit bf5360f9 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

fix some bugs

parent 8e36f002
Hide whitespace changes
Inline Side-by-side
Showing with 100 additions and 94 deletions
src/Gargantext/Viz/Phylo.hs
View file @ bf5360f9
......@@ -75,17 +75,17 @@ data Software =
data Phylo =
Phylo { _phylo_duration :: (Start, End)
, _phylo_foundations :: Vector Ngrams
, _phylo_foundationsPeaks :: PhyloPeaks
, _phylo_foundationsRoots :: PhyloRoots
, _phylo_periods :: [PhyloPeriod]
, _phylo_param :: PhyloParam
}
deriving (Generic, Show, Eq)
-- | The PhyloPeaks describe the aggregation of some foundations Ngrams behind a list of Ngrams trees (ie: a forest)
-- | The PhyloRoots describe the aggregation of some foundations Ngrams behind a list of Ngrams trees (ie: a forest)
-- PeaksLabels are the root labels of each Ngrams trees
data PhyloPeaks =
PhyloPeaks { _phylo_peaksLabels :: Vector Ngrams
, _phylo_peaksForest :: [Tree Ngrams]
data PhyloRoots =
PhyloRoots { _phylo_rootsLabels :: Vector Ngrams
, _phylo_rootsForest :: [Tree Ngrams]
}
deriving (Generic, Show, Eq)
......@@ -307,8 +307,7 @@ data Metric = BranchAge deriving (Generic, Show, Eq, Read)
-- | Tagger constructors
data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics
deriving (Generic, Show, Read)
data Tagger = BranchPeakFreq | GroupLabelCooc | GroupDynamics deriving (Show)
--------------
......@@ -365,6 +364,7 @@ data PhyloView = PhyloView
, _pv_description :: Text
, _pv_filiation :: Filiation
, _pv_level :: Level
, _pv_periods :: [PhyloPeriodId]
, _pv_metrics :: Map Text [Double]
, _pv_branches :: [PhyloBranch]
, _pv_nodes :: [PhyloNode]
......@@ -374,7 +374,7 @@ data PhyloView = PhyloView
-- | A phyloview is made of PhyloBranches, edges and nodes
data PhyloBranch = PhyloBranch
{ _pb_id :: PhyloBranchId
, _pb_label :: Text
, _pb_peak :: Text
, _pb_metrics :: Map Text [Double]
} deriving (Generic, Show)
......@@ -441,7 +441,7 @@ makeLenses ''PhyloParam
makeLenses ''Software
--
makeLenses ''Phylo
makeLenses ''PhyloPeaks
makeLenses ''PhyloRoots
makeLenses ''PhyloGroup
makeLenses ''PhyloLevel
makeLenses ''PhyloPeriod
......@@ -466,7 +466,7 @@ makeLenses ''PhyloEdge
$(deriveJSON (unPrefix "_phylo_" ) ''Phylo )
$(deriveJSON (unPrefix "_phylo_peaks" ) ''PhyloPeaks )
$(deriveJSON (unPrefix "_phylo_roots" ) ''PhyloRoots )
$(deriveJSON defaultOptions ''Tree )
$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
$(deriveJSON (unPrefix "_phylo_level" ) ''PhyloLevel )
......
src/Gargantext/Viz/Phylo/Aggregates/Cooc.hs
View file @ bf5360f9
......@@ -31,7 +31,7 @@ fisToCooc :: Map (Date, Date) [PhyloFis] -> Phylo -> Map (Int, Int) Double
fisToCooc m p = map (/docs)
$ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc
$ concat
$ map (\x -> listToUnDirectedCombiWith (\y -> getIdxInPeaks y p) $ (Set.toList . getClique) x)
$ map (\x -> listToUnDirectedCombiWith (\y -> getIdxInRoots y p) $ (Set.toList . getClique) x)
$ (concat . elems) m
where
--------------------------------------
......@@ -42,7 +42,7 @@ fisToCooc m p = map (/docs)
docs = fromIntegral $ foldl (\mem x -> mem + (getSupport x)) 0 $ (concat . elems) m
--------------------------------------
cooc :: Map (Int, Int) (Double)
cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\y -> getIdxInPeaks y p) fisNgrams)
cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\y -> getIdxInRoots y p) fisNgrams)
--------------------------------------
......
src/Gargantext/Viz/Phylo/Aggregates/Document.hs
View file @ bf5360f9
......@@ -50,27 +50,28 @@ groupDocsByPeriod f pds es = Map.fromList $ zip pds $ map (inPeriode f es) pds
fst $ List.partition (\d -> f' d >= start && f' d <= end) h
--------------------------------------
reduceByPeaks :: Map Ngrams Ngrams -> [Ngrams] -> [Ngrams]
reduceByPeaks m ns = (\(f,s) -> f ++ (nub s))
-- | Reduce a list of foundations as a list of corresponding roots
reduceByRoots :: Map Ngrams Ngrams -> [Ngrams] -> [Ngrams]
reduceByRoots m ns = (\(f,s) -> f ++ (nub s))
$ foldl (\mem n -> if member n m
then (fst mem,(snd mem) ++ [m Map.! n])
else ((fst mem) ++ [n],snd mem)
) ([],[]) ns
-- | To parse a list of Documents by filtering on a Vector of Ngrams
parseDocs :: Vector Ngrams -> PhyloPeaks -> [(Date,Text)] -> [Document]
parseDocs fds peaks c = map (\(d,t)
-> Document d ( reduceByPeaks mPeaks
parseDocs :: Vector Ngrams -> PhyloRoots -> [(Date,Text)] -> [Document]
parseDocs fds roots c = map (\(d,t)
-> Document d ( reduceByRoots mRoots
$ filter (\x -> Vector.elem x fds)
$ monoTexts t)) c
where
--------------------------------------
mPeaks :: Map Ngrams Ngrams
mPeaks = forestToMap (peaks ^. phylo_peaksForest)
mRoots :: Map Ngrams Ngrams
mRoots = forestToMap (roots ^. phylo_rootsForest)
--------------------------------------
-- | To transform a Corpus of texts into a Map of aggregated Documents grouped by Periods
corpusToDocs :: [(Date,Text)] -> Phylo -> Map (Date,Date) [Document]
corpusToDocs c p = groupDocsByPeriod date (getPhyloPeriods p)
$ parseDocs (getFoundations p) (getPeaks p) c
$ parseDocs (getFoundations p) (getRoots p) c
src/Gargantext/Viz/Phylo/Example.hs
View file @ bf5360f9
......@@ -53,6 +53,8 @@ import qualified Data.List as List
-- | STEP 12 | -- Create a PhyloView from a user Query
------------------------------------------------------
export :: IO ()
export = dotToFile "./export_test" "cesar_cleopatre.dot" phyloDot
phyloDot :: DotGraph DotId
phyloDot = viewToDot phyloView
......@@ -69,12 +71,12 @@ queryViewEx = "level=3"
++ "&childs=false"
++ "&filter=LonelyBranchFilter"
++ "&metric=BranchAge"
++ "&tagger=BranchLabelFreq"
++ "&tagger=BranchPeakFreq"
++ "&tagger=GroupLabelCooc"
phyloQueryView :: PhyloQueryView
phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchLabelFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [defaultSmallBranch] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
--------------------------------------------------
......@@ -87,7 +89,7 @@ phyloFromQuery = toPhylo (queryParser queryEx) corpus actants actantsTrees
-- | To do : create a request handler and a query parser
queryParser :: [Char] -> PhyloQueryBuild
queryParser _q = phyloQuery
queryParser _q = phyloQueryBuild
queryEx :: [Char]
queryEx = "title=Cesar et Cleôpatre"
......@@ -99,8 +101,8 @@ queryEx = "title=Cesar et Cleôpatre"
++ "nthCluster=RelatedComponents"
++ "nthProximity=Filiation"
phyloQuery :: PhyloQueryBuild
phyloQuery = PhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
phyloQueryBuild :: PhyloQueryBuild
phyloQueryBuild = PhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
5 3 defaultFis [] [] defaultWeightedLogJaccard 3 defaultRelatedComponents
......@@ -199,7 +201,7 @@ phylo1 = addPhyloLevel (1) phyloFis phylo
phyloFis :: Map (Date, Date) [PhyloFis]
phyloFis = filterFisByNested $ filterFisBySupport False 1 (docsToFis phyloDocs)
phyloFis = filterFisByNested $ filterFisBySupport True 1 (docsToFis phyloDocs)
----------------------------------------
......@@ -221,7 +223,7 @@ phyloDocs = corpusToDocs corpus phyloBase
phyloBase :: Phylo
phyloBase = initPhyloBase periods foundations peaks defaultPhyloParam
phyloBase = initPhyloBase periods foundations roots defaultPhyloParam
periods :: [(Date,Date)]
......@@ -229,8 +231,8 @@ periods = initPeriods 5 3
$ both fst (head' "Example" corpus,last corpus)
peaks :: PhyloPeaks
peaks = initPeaks (map (\t -> alterLabels phyloAnalyzer t) actantsTrees) foundations
roots :: PhyloRoots
roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) actantsTrees) foundations
foundations :: Vector Ngrams
......@@ -242,7 +244,8 @@ foundations = initFoundations actants
--------------------------------------------
actantsTrees :: [Tree Ngrams]
actantsTrees = [Node "Cite antique" [(Node "Rome" []),(Node "Alexandrie" [])]]
actantsTrees = []
-- actantsTrees = [Node "Cite antique" [(Node "Rome" []),(Node "Alexandrie" [])]]
actants :: [Ngrams]
......
src/Gargantext/Viz/Phylo/LevelMaker.hs
View file @ bf5360f9
......@@ -112,7 +112,7 @@ cliqueToGroup prd lvl idx lbl fis m p =
where
--------------------------------------
ngrams :: [Int]
ngrams = sort $ map (\x -> getIdxInPeaks x p)
ngrams = sort $ map (\x -> getIdxInRoots x p)
$ Set.toList
$ getClique fis
--------------------------------------
......@@ -125,7 +125,7 @@ cliqueToGroup prd lvl idx lbl fis m 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 -> getIdxInPeaks x p) ngrams) empty empty Nothing [] [] [] []
PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInRoots x p) ngrams) empty empty Nothing [] [] [] []
-- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
......@@ -182,11 +182,11 @@ toPhylo0 d p = addPhyloLevel 0 d p
-- | To reconstruct the Base of a Phylo
toPhyloBase :: PhyloQueryBuild -> PhyloParam -> [(Date, Text)] -> [Ngrams] -> [Tree Ngrams] -> Phylo
toPhyloBase q p c a ts = initPhyloBase periods foundations peaks p
toPhyloBase q p c a ts = initPhyloBase periods foundations roots p
where
--------------------------------------
peaks :: PhyloPeaks
peaks = initPeaks (map (\t -> alterLabels phyloAnalyzer t) ts) foundations
roots :: PhyloRoots
roots = initRoots (map (\t -> alterLabels phyloAnalyzer t) ts) foundations
--------------------------------------
periods :: [(Date,Date)]
periods = initPeriods (getPeriodGrain q) (getPeriodSteps q)
......
src/Gargantext/Viz/Phylo/LinkMaker.hs
View file @ bf5360f9
......@@ -90,8 +90,8 @@ applyProximity prox g1 g2 = case prox of
-- | To get the next or previous PhyloPeriod based on a given PhyloPeriodId
getNextPeriods :: Filiation -> PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
getNextPeriods to' id l = case to' of
Descendant -> unNested id ((tail . snd) next)
Ascendant -> unNested id ((reverse . fst) next)
Descendant -> (tail . snd) next
Ascendant -> (reverse . fst) next
_ -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] Filiation type not defined")
where
--------------------------------------
......@@ -103,17 +103,6 @@ getNextPeriods to' id l = case to' of
Nothing -> panic ("[ERR][Viz.Phylo.Example.getNextPeriods] PhyloPeriodId not defined")
Just i -> i
--------------------------------------
-- | To have an non-overlapping next period
unNested :: PhyloPeriodId -> [PhyloPeriodId] -> [PhyloPeriodId]
unNested x l'
| null l' = []
| nested (fst $ head' "getNextPeriods1" l') x = unNested x (tail l')
| nested (snd $ head' "getNextPeriods2" l') x = unNested x (tail l')
| otherwise = l
--------------------------------------
nested :: Date -> PhyloPeriodId -> Bool
nested d prd = d >= fst prd && d <= snd prd
--------------------------------------
-- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ bf5360f9
......@@ -146,14 +146,12 @@ initFoundations :: [Ngrams] -> Vector Ngrams
initFoundations l = Vector.fromList $ map phyloAnalyzer l
-- | To init the base of a Phylo from a List of Periods and Foundations
initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloPeaks -> PhyloParam -> Phylo
initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> PhyloRoots -> PhyloParam -> Phylo
initPhyloBase pds fds pks prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds pks (map (\pd -> initPhyloPeriod pd []) pds) prm
-- | To init the param of a Phylo
initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
initPhyloParam (def defaultPhyloVersion -> v)
(def defaultSoftware -> s)
(def defaultQueryBuild -> q) = PhyloParam v s q
initPhyloParam (def defaultPhyloVersion -> v) (def defaultSoftware -> s) (def defaultQueryBuild -> q) = PhyloParam v s q
-- | To get the foundations of a Phylo
getFoundations :: Phylo -> Vector Ngrams
......@@ -176,7 +174,7 @@ getLastLevel p = (last . sort)
--------------------
-- | PhyloPeaks | --
-- | PhyloRoots | --
--------------------
-- | To apply a fonction to each label of a Ngrams Tree
......@@ -191,23 +189,23 @@ forestToMap trees = Map.fromList $ concat $ map treeToTuples' trees
treeToTuples' (Node lbl ns) = treeToTuples (Node lbl ns) lbl
treeToTuples' Empty = panic "[ERR][Viz.Phylo.Tools.forestToMap] Empty"
-- | To get the foundationsPeaks of a Phylo
getPeaks :: Phylo -> PhyloPeaks
getPeaks = _phylo_foundationsPeaks
-- | To get the foundationsRoots of a Phylo
getRoots :: Phylo -> PhyloRoots
getRoots = _phylo_foundationsRoots
-- | To get the peaksLabels of a Phylo
getPeaksLabels :: Phylo -> Vector Ngrams
getPeaksLabels p = (getPeaks p) ^. phylo_peaksLabels
-- | To get the RootsLabels of a Phylo
getRootsLabels :: Phylo -> Vector Ngrams
getRootsLabels p = (getRoots p) ^. phylo_rootsLabels
-- | To get the Index of a Ngrams in the foundationsPeaks of a Phylo
getIdxInPeaks :: Ngrams -> Phylo -> Int
getIdxInPeaks n p = case (elemIndex n (getPeaksLabels p)) of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getIdxInPeaks] Ngrams not in foundationsPeaks"
-- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
getIdxInRoots :: Ngrams -> Phylo -> Int
getIdxInRoots n p = case (elemIndex n (getRootsLabels p)) of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
Just idx -> idx
-- | To init the PhyloPeaks of a Phylo
initPeaks :: [Tree Ngrams] -> Vector Ngrams -> PhyloPeaks
initPeaks trees ns = PhyloPeaks labels trees
-- | To init the PhyloRoots of a Phylo
initRoots :: [Tree Ngrams] -> Vector Ngrams -> PhyloRoots
initRoots trees ns = PhyloRoots labels trees
where
--------------------------------------
labels :: Vector Ngrams
......@@ -387,7 +385,7 @@ initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
initGroup ngrams lbl idx lvl from' to' p = PhyloGroup
(((from', to'), lvl), idx)
lbl
(sort $ map (\x -> getIdxInPeaks x p) ngrams)
(sort $ map (\x -> getIdxInRoots x p) ngrams)
(Map.empty)
(Map.empty)
Nothing
......@@ -710,8 +708,8 @@ initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
-- | To initialize a PhyloQuery from given and default parameters
initPhyloQueryBuild :: Maybe Text -> Maybe Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
-- | 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 Level -> Maybe Cluster -> PhyloQueryBuild
initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
(def defaultWeightedLogJaccard -> matching') (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
PhyloQueryBuild name' desc' grain steps cluster metrics filters matching' nthLevel nthCluster
......@@ -767,11 +765,8 @@ defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing N
-- Queries
defaultQueryBuild :: PhyloQueryBuild
defaultQueryBuild = initPhyloQueryBuild (Just "Cesar et Cleôpatre")
(Just "An example of Phylomemy (french without accent)")
Nothing Nothing Nothing
Nothing Nothing Nothing
Nothing Nothing
defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
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 @ bf5360f9
......@@ -26,18 +26,31 @@ import Data.GraphViz.Types.Monadic
import Data.List ((++),unwords,concat,sortOn,nub)
import Data.Map (Map,toList)
import Data.Maybe (isNothing,fromJust)
import Data.Text.Lazy (fromStrict, pack)
import Data.Text.Lazy (fromStrict, pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.Lazy as T'
import qualified Data.GraphViz.Attributes.HTML as H
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo hiding (Dot)
import Gargantext.Viz.Phylo.Tools
import Prelude (writeFile)
import System.FilePath
type DotId = T'.Text
---------------------
-- | Dot to File | --
---------------------
dotToFile :: FilePath -> FilePath -> DotGraph DotId -> IO ()
dotToFile filePath fileName dotG = writeFile (combine filePath fileName) $ unpack (printDotGraph dotG)
--------------------------
-- | PhyloView to DOT | --
--------------------------
......@@ -105,7 +118,7 @@ toDotLabel lbl = StrLabel $ fromStrict lbl
-- | To set a Peak Node
setPeakDotNode :: PhyloBranch -> Dot DotId
setPeakDotNode pb = node (toBranchDotId $ pb ^. pb_id)
([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_label)]
([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ pb ^. pb_peak)]
<> (setAttrFromMetrics $ pb ^. pb_metrics))
......@@ -187,7 +200,7 @@ viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
mapM setDotNode $ filterNodesByPeriod prd $ filterNodesByLevel (pv ^. pv_level) (pv ^.pv_nodes)
) $ getViewPeriods pv
) $ (pv ^. pv_periods)
-- set the edges : from peaks to nodes, from nodes to nodes, from periods to periods
......@@ -195,7 +208,7 @@ viewToDot pv = digraph ((Str . fromStrict) $ pv ^. pv_title)
_ <- mapM setDotEdge $ filterEdgesByLevel (pv ^. pv_level) $ filterEdgesByType PeriodEdge (pv ^. pv_edges)
mapM setDotPeriodEdge $ listToSequentialCombi $ getViewPeriods pv
mapM setDotPeriodEdge $ listToSequentialCombi $ (pv ^. pv_periods)
......
src/Gargantext/Viz/Phylo/View/Taggers.hs
View file @ bf5360f9
......@@ -64,19 +64,19 @@ mostOccNgrams thr group = (nub . concat )
$ reverse $ sortOn snd $ Map.toList $ getGroupCooc group
-- | To alter the label of a PhyloBranch
alterBranchLabel :: (PhyloBranchId,Text) -> PhyloView -> PhyloView
alterBranchLabel (id,lbl) v = over (pv_branches
-- | To alter the peak of a PhyloBranch
alterBranchPeak :: (PhyloBranchId,Text) -> PhyloView -> PhyloView
alterBranchPeak (id,lbl) v = over (pv_branches
. traverse)
(\b -> if getBranchId b == id
then b & pb_label .~ lbl
then b & pb_peak .~ lbl
else b) v
-- | To set the label of a PhyloBranch as the nth most frequent terms of its PhyloNodes
branchLabelFreq :: PhyloView -> Int -> Phylo -> PhyloView
branchLabelFreq v thr p = foldl (\v' (id,lbl) -> alterBranchLabel (id,lbl) v') v
$ map (\(id,ns) -> (id, freqToLabel thr (getPeaksLabels p)
-- | To set the peak of a PhyloBranch as the nth most frequent terms of its PhyloNodes
branchPeakFreq :: PhyloView -> Int -> Phylo -> PhyloView
branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
$ map (\(id,ns) -> (id, freqToLabel thr (getRootsLabels p)
$ getGroupsFromNodes ns p))
$ getNodesByBranches v
......@@ -85,7 +85,7 @@ branchLabelFreq v thr p = foldl (\v' (id,lbl) -> alterBranchLabel (id,lbl) v') v
nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
nodeLabelCooc v thr p = over (pv_nodes
. traverse)
(\n -> let lbl = ngramsToLabel (getPeaksLabels p)
(\n -> let lbl = ngramsToLabel (getRootsLabels p)
$ mostOccNgrams thr
$ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
in n & pn_label .~ lbl) v
......@@ -94,7 +94,7 @@ nodeLabelCooc v thr p = over (pv_nodes
-- | To process a sorted list of Taggers to a PhyloView
processTaggers :: [Tagger] -> Phylo -> PhyloView -> PhyloView
processTaggers ts p v = foldl (\v' t -> case t of
BranchLabelFreq -> branchLabelFreq v' 2 p
GroupLabelCooc -> nodeLabelCooc v' 2 p
_ -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts
BranchPeakFreq -> branchPeakFreq v' 2 p
GroupLabelCooc -> nodeLabelCooc v' 2 p
_ -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts
src/Gargantext/Viz/Phylo/View/ViewMaker.hs
View file @ bf5360f9
......@@ -45,9 +45,11 @@ initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
-- | To init a PhyloView
initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl empty
initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl lvl
(getPhyloPeriods p)
empty
([] ++ (phyloToBranches lvl p))
([] ++ (groupsToNodes True vb (getPeaksLabels p) gs))
([] ++ (groupsToNodes True vb (getRootsLabels p) gs))
([] ++ (groupsToEdges fl PeriodEdge gs))
where
--------------------------------------
......@@ -74,6 +76,7 @@ groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
) gs
-- | To merge edges by keeping the maximum weight
mergeEdges :: [PhyloEdge] -> [PhyloEdge] -> [PhyloEdge]
mergeEdges lAsc lDes = elems
$ unionWithKey (\_k vAsc vDes -> vDes & pe_weight .~ (max (vAsc ^. pe_weight) (vDes ^. pe_weight))) mAsc mDes
......@@ -81,6 +84,8 @@ mergeEdges lAsc lDes = elems
--------------------------------------
mAsc :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
mAsc = fromList
$ map (\(k,e) -> (k, e & pe_source .~ fst k
& pe_target .~ snd k))
$ zip (map (\e -> (e ^. pe_target,e ^. pe_source)) lAsc) lAsc
--------------------------------------
mDes :: Map (PhyloGroupId,PhyloGroupId) PhyloEdge
......@@ -118,7 +123,7 @@ addChildNodes shouldDo lvl lvlMin vb fl p v =
then v
else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
$ v & pv_branches %~ (++ (phyloToBranches (lvl - 1) p))
& pv_nodes %~ (++ (groupsToNodes False vb (getPeaksLabels p) gs'))
& pv_nodes %~ (++ (groupsToNodes False vb (getRootsLabels p) gs'))
& pv_edges %~ (++ (groupsToEdges fl PeriodEdge gs'))
& pv_edges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
& pv_edges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
......
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