Commit 1ed453ca authored by Quentin Lobbé's avatar Quentin Lobbé

add the foundations to the phylo

parent 710d79c5
...@@ -66,15 +66,14 @@ data Software = ...@@ -66,15 +66,14 @@ data Software =
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | Phylo datatype descriptor of a phylomemy -- | Phylo datatype of a phylomemy
-- Duration : time Segment of the whole phylomemy (start,end) -- Duration : time Segment of the whole Phylo
-- Ngrams : list of all (possible) terms contained in the phylomemy (with their id) -- Foundations : vector of all the Ngrams contained in a Phylo (build from a list of actants)
-- Steps : list of all steps to build the phylomemy -- Periods : list of all the periods of a Phylo
data Phylo = data Phylo =
Phylo { _phylo_duration :: (Start, End) Phylo { _phylo_duration :: (Start, End)
, _phylo_ngrams :: PhyloNgrams , _phylo_foundations :: Vector Ngrams
, _phylo_periods :: [PhyloPeriod] , _phylo_periods :: [PhyloPeriod]
, _phylo_branches :: [PhyloBranch]
} }
deriving (Generic, Show) deriving (Generic, Show)
...@@ -157,12 +156,8 @@ type PhyloBranchId = (Level, Index) ...@@ -157,12 +156,8 @@ type PhyloBranchId = (Level, Index)
type Weight = Double type Weight = Double
-- | Pointer : A weighted linked with a given PhyloGroup -- | Pointer : A weighted linked with a given PhyloGroup
type Pointer = (PhyloGroupId, Weight) type Pointer = (PhyloGroupId, Weight)
-- | Ngrams : a contiguous sequence of n terms -- | Ngrams : a contiguous sequence of n terms
type Ngrams = Text type Ngrams = Text
-- | PhyloNgrams : Vector of all the Ngrams (PhyloGroup of level -1) used within a Phylo
type PhyloNgrams = Vector Ngrams
-- | Clique : Set of ngrams cooccurring in the same Document -- | Clique : Set of ngrams cooccurring in the same Document
...@@ -204,6 +199,7 @@ data Clustering = Louvain | RelatedComponents ...@@ -204,6 +199,7 @@ data Clustering = Louvain | RelatedComponents
data PairTo = Childs | Parents data PairTo = Childs | Parents
-- | Lenses -- | Lenses
makeLenses ''Phylo makeLenses ''Phylo
makeLenses ''PhyloParam makeLenses ''PhyloParam
......
...@@ -37,7 +37,7 @@ fisToCooc :: Map (Date, Date) [Fis] -> Phylo -> Map (Int, Int) Double ...@@ -37,7 +37,7 @@ fisToCooc :: Map (Date, Date) [Fis] -> Phylo -> Map (Int, Int) Double
fisToCooc m p = map (/docs) fisToCooc m p = map (/docs)
$ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc $ foldl (\mem x -> adjust (+1) (getKeyPair x mem) mem) cooc
$ concat $ concat
$ map (\x -> listToUnDirectedCombiWith (\x -> ngramsToIdx x p) $ (Set.toList . fst) x) $ map (\x -> listToUnDirectedCombiWith (\x -> getIdxInFoundations x p) $ (Set.toList . fst) x)
$ (concat . elems) m $ (concat . elems) m
where where
-------------------------------------- --------------------------------------
...@@ -48,5 +48,5 @@ fisToCooc m p = map (/docs) ...@@ -48,5 +48,5 @@ fisToCooc m p = map (/docs)
docs = fromIntegral $ foldl (\mem x -> mem + (snd x)) 0 $ (concat . elems) m docs = fromIntegral $ foldl (\mem x -> mem + (snd x)) 0 $ (concat . elems) m
-------------------------------------- --------------------------------------
cooc :: Map (Int, Int) (Double) cooc :: Map (Int, Int) (Double)
cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\x -> ngramsToIdx x p) fisNgrams) cooc = Map.fromList $ map (\x -> (x,0)) (listToUnDirectedCombiWith (\x -> getIdxInFoundations x p) fisNgrams)
-------------------------------------- --------------------------------------
\ No newline at end of file
...@@ -34,38 +34,45 @@ import qualified Data.Map as Map ...@@ -34,38 +34,45 @@ import qualified Data.Map as Map
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
-- | To init a set of periods out of a given Grain and Step -- | To init a list of Periods framed by a starting Date and an ending Date
docsToPeriods :: (Ord date, Enum date) => (doc -> date) initPeriods :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
-> Grain -> Step -> [doc] -> Map (date, date) [doc] initPeriods g s (start,end) = map (\l -> (head l, last l))
docsToPeriods _ _ _ [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods" $ chunkAlong g s [start .. end]
docsToPeriods f g s es = Map.fromList $ zip hs $ map (inPeriode f es) hs
-- | To be defined, for the moment it's just the id function
groupNgramsWithTrees :: Ngrams -> Ngrams
groupNgramsWithTrees n = n
-- | To group a list of Documents by fixed periods
groupDocsByPeriod :: (Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
groupDocsByPeriod _ _ [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
groupDocsByPeriod f pds es = Map.fromList $ zip pds $ map (inPeriode f es) pds
where where
--------------------------------------
hs = steps g s $ both f (head es, last es)
-------------------------------------- --------------------------------------
inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t] inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
inPeriode f' h (start,end) = inPeriode f' h (start,end) =
fst $ List.partition (\d -> f' d >= start && f' d <= end) h fst $ List.partition (\d -> f' d >= start && f' d <= end) h
-------------------------------------- --------------------------------------
steps :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
steps s' o' (start,end) = map (\l -> (head l, last l))
$ chunkAlong s' o' [start .. end]
--------------------------------------
-- | To parse a list of Documents by filtering on a Vector of Ngrams -- | To parse a list of Documents by filtering on a Vector of Ngrams
parseDocs :: PhyloNgrams -> [Document] -> [Document] parseDocs :: (Ngrams -> Ngrams) -> Vector Ngrams -> [Document] -> [Document]
parseDocs l docs = map (\(Document d t) parseDocs f l docs = map (\(Document d t)
-> Document d ( unwords -> Document d ( unwords
-- | To do : change 'f' for the Ngrams Tree Agregation
$ map f
$ filter (\x -> Vector.elem x l) $ filter (\x -> Vector.elem x l)
$ monoTexts t)) docs $ monoTexts t)) docs
-- | To group a list of Documents by fixed periods -- | To transform a Corpus of texts into a Map of aggregated Documents grouped by Periods
groupDocsByPeriod :: Grain -> Step -> [Document] -> PhyloNgrams -> Map (Date, Date) [Document] corpusToDocs :: (Ngrams -> Ngrams) -> [(Date,Text)] -> Phylo -> Map (Date,Date) [Document]
groupDocsByPeriod g s docs ngrams = docsToPeriods date g s $ parseDocs ngrams docs corpusToDocs f c p = groupDocsByPeriod date (getPhyloPeriods p)
$ parseDocs f (getFoundations p) docs
where
-- | To transform a corpus of texts into a structured list of Documents --------------------------------------
corpusToDocs :: [(Date, Text)] -> [Document] docs :: [Document]
corpusToDocs l = map (\(d,t) -> Document d t) l docs = map (\(d,t) -> Document d t) c
\ No newline at end of file --------------------------------------
\ No newline at end of file
...@@ -60,5 +60,5 @@ groupsToGraph (prox,param) groups p = (groups,edges) ...@@ -60,5 +60,5 @@ groupsToGraph (prox,param) groups p = (groups,edges)
-- | To set all the PhyloBranches for a given Level in a Phylo -- | To set all the PhyloBranches for a given Level in a Phylo
setPhyloBranches :: Level -> Phylo -> Phylo -- setPhyloBranches :: Level -> Phylo -> Phylo
setPhyloBranches lvl p = alterPhyloBranches (\l -> l ++ (graphToBranches lvl (groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p) p) ) p -- setPhyloBranches lvl p = alterPhyloBranches (\l -> l ++ (graphToBranches lvl (groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p) p) ) p
\ No newline at end of file \ No newline at end of file
...@@ -31,7 +31,7 @@ module Gargantext.Viz.Phylo.Example where ...@@ -31,7 +31,7 @@ module Gargantext.Viz.Phylo.Example where
import Control.Lens hiding (makeLenses, both, Level) import Control.Lens hiding (makeLenses, both, Level)
import Data.Bool (Bool, not) import Data.Bool (Bool, not)
import Data.List (concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete, init, groupBy) import Data.List (notElem, concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete, init, groupBy)
import Data.Map (Map, elems, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith) import Data.Map (Map, elems, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
import Data.Set (Set) import Data.Set (Set)
...@@ -76,17 +76,17 @@ getBranchPeriods b = nub $ map (fst . fst) $ getBranchGroupIds b ...@@ -76,17 +76,17 @@ getBranchPeriods b = nub $ map (fst . fst) $ getBranchGroupIds b
-- | To get all the single PhyloPeriodIds covered by a PhyloBranch -- | To get all the single PhyloPeriodIds covered by a PhyloBranch
getBranchGroupIds :: PhyloBranch -> [PhyloGroupId] getBranchGroupIds :: PhyloBranch -> [PhyloGroupId]
getBranchGroupIds b =_phylo_branchGroups b getBranchGroupIds =_phylo_branchGroups
-- | To transform a list of Ngrams Indexes into a Label -- | To transform a list of Ngrams Indexes into a Label
ngramsToLabel :: [Int] -> PhyloNgrams -> Text ngramsToLabel :: Vector Ngrams -> [Int] -> Text
ngramsToLabel l ngrams = unwords $ ngramsToText l ngrams ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
-- | To transform a list of Ngrams Indexes into a list of Text -- | To transform a list of Ngrams Indexes into a list of Text
ngramsToText :: [Int] -> PhyloNgrams -> [Text] ngramsToText :: Vector Ngrams -> [Int] -> [Text]
ngramsToText l ngrams = map (\idx -> ngrams Vector.! idx) l ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
-- | To get the nth most frequent Ngrams in a list of PhyloGroups -- | To get the nth most frequent Ngrams in a list of PhyloGroups
...@@ -109,23 +109,33 @@ mostOccNgrams thr group = (nub . concat ) ...@@ -109,23 +109,33 @@ mostOccNgrams thr group = (nub . concat )
$ reverse $ sortOn snd $ Map.toList $ getGroupCooc group $ reverse $ sortOn snd $ Map.toList $ getGroupCooc group
freqToLabel :: Int -> [PhyloGroup] -> Vector Ngrams -> Text
freqToLabel thr l ngs = ngramsToLabel ngs $ mostFreqNgrams thr l
filterLoneBranches :: Int -> Int -> Int -> [PhyloPeriod] -> [PhyloBranch]
-- | To filter a list of Branches by avoiding the lone's one (ie: with just a few phyloGroups in the middle of the whole timeline)
filterLoneBranches :: Int -> Int -> Int -> [PhyloPeriodId] -> [PhyloBranch] -> [PhyloBranch]
filterLoneBranches nbPinf nbPsup nbG periods branches = filter (not . isLone) branches filterLoneBranches nbPinf nbPsup nbG periods branches = filter (not . isLone) branches
where where
isLone :: PhyloBranch -> Boolean --------------------------------------
isLone b = ((length . getBranchGroups) b <= nbG) isLone :: PhyloBranch -> Bool
isLone b = ((length . getBranchGroupIds) b <= nbG)
&& notElem ((head . getBranchPeriods) b) (take nbPinf periods) && notElem ((head . getBranchPeriods) b) (take nbPinf periods)
&& notElem ((head . getBranchPeriods) b) (take nbPsup reverse periods) && notElem ((head . getBranchPeriods) b) (take nbPsup $ reverse periods)
--------------------------------------
-- alterBranchLabel :: (Int -> [PhyloGroup] -> Vector Ngrams -> Text) -> PhyloBranch -> Phylo -> PhyloBranch
-- alterBranchLabel f b p = over (phylo_branchLabel) (\lbl -> f 2 (getGroupsFromIds (getBranchGroupIds b) p) (getVector Ngrams p)) b
toPhyloView :: Level -> Phylo -> [PhyloBranch] -- toPhyloView1 :: Level -> Phylo -> [PhyloBranch]
toPhyloView lvl p = branchesLbl -- toPhyloView1 lvl p = bs
where -- where
branchesLbl = map (\b -> over (phylo_branchLabel) (\lbl -> "toto") b) branches -- bs = map (\b -> alterBranchLabel freqToLabel b p)
branches = filter (\b -> (fst . _phylo_branchId) b == lvl) $ getPhyloBranches p -- $ filterLoneBranches 1 1 1 (getPhyloPeriods p)
-- $ filter (\b -> (fst . _phylo_branchId) b == lvl)
-- $ getPhyloBranches p
view1 = toPhyloView 2 phylo3 -- view1 = toPhyloView1 2 phylo3
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo -- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
...@@ -136,8 +146,7 @@ phylo6 = toNthLevel 6 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) (Wei ...@@ -136,8 +146,7 @@ phylo6 = toNthLevel 6 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) (Wei
phylo3 :: Phylo phylo3 :: Phylo
phylo3 = setPhyloBranches 3 phylo3 = pairGroupsToGroups Childs 3 (WeightedLogJaccard,[0.01,0])
$ pairGroupsToGroups Childs 3 (WeightedLogJaccard,[0.01,0])
$ pairGroupsToGroups Parents 3 (WeightedLogJaccard,[0.01,0]) $ pairGroupsToGroups Parents 3 (WeightedLogJaccard,[0.01,0])
$ setLevelLinks (2,3) $ setLevelLinks (2,3)
$ addPhyloLevel 3 $ addPhyloLevel 3
...@@ -149,7 +158,8 @@ phylo3 = setPhyloBranches 3 ...@@ -149,7 +158,8 @@ phylo3 = setPhyloBranches 3
-- | STEP 10 | -- Cluster the Fis -- | STEP 10 | -- Cluster the Fis
phyloBranch2 :: Phylo phyloBranch2 :: Phylo
phyloBranch2 = setPhyloBranches 2 phylo2_c phyloBranch2 = phylo2_c
-- phyloBranch2 = setPhyloBranches 2 phylo2_c
phylo2_c :: Phylo phylo2_c :: Phylo
...@@ -177,8 +187,10 @@ phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0.01,0]) (RelatedComponent ...@@ -177,8 +187,10 @@ phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0.01,0]) (RelatedComponent
-- | STEP 9 | -- Find the Branches -- | STEP 9 | -- Find the Branches
phyloBranch1 :: Phylo phyloBranch1 = phylo1_c
phyloBranch1 = setPhyloBranches 1 phylo1_c
-- phyloBranch1 :: Phylo
-- phyloBranch1 = setPhyloBranches 1 phylo1_c
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -214,7 +226,7 @@ phylo1_1_0 = setLevelLinks (1,0) phylo1 ...@@ -214,7 +226,7 @@ phylo1_1_0 = setLevelLinks (1,0) phylo1
phylo1 :: Phylo phylo1 :: Phylo
phylo1 = addPhyloLevel (1) phyloFis phylo0_m1_0 phylo1 = addPhyloLevel (1) phyloFis phylo
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -226,46 +238,36 @@ phyloFis = filterFisBySupport False 1 (filterFisByNested (docsToFis phyloDocs)) ...@@ -226,46 +238,36 @@ phyloFis = filterFisBySupport False 1 (filterFisByNested (docsToFis phyloDocs))
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | STEP 4 | -- Link level 0 to level -1 and reverse -- | STEP 2 | -- Init a Phylo of level 0
phylo0_m1_0 :: Phylo
phylo0_m1_0 = setLevelLinks ((-1),0) phylo0_0_m1
phylo0_0_m1 :: Phylo
phylo0_0_m1 = setLevelLinks (0,(-1)) phylo0
------------------------------------------------------------------------ -- phylo' :: Phylo
-- | STEP 3 | -- Build level 0 as a copy of level -1 -- phylo' = initPhylo 5 3 corpus actants groupNgramsWithTrees
-- | To do : build a real level 0 !
-- | To clone the last PhyloLevel of each PhyloPeriod and update it with a new LevelValue phylo :: Phylo
clonePhyloLevel :: Level -> Phylo -> Phylo phylo = addPhyloLevel 0 phyloDocs phyloBase
clonePhyloLevel lvl p = alterPhyloLevels (\l -> l ++ [setPhyloLevelId lvl $ head l]) p
phylo0 :: Phylo phyloDocs :: Map (Date, Date) [Document]
phylo0 = clonePhyloLevel 0 phylo phyloDocs = corpusToDocs groupNgramsWithTrees corpus phyloBase
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- | STEP 2 | -- Init a Phylo of level -1 with the Documents -- | STEP 1 | -- Init the Base of the Phylo from Periods and Foundations
phylo :: Phylo phyloBase :: Phylo
phylo = addPhyloLevel (-1) phyloDocs phyloBase = initPhyloBase periods foundations
$ initPhylo (keys phyloDocs) (initNgrams actants)
------------------------------------------------------------------------ periods :: [(Date,Date)]
-- | STEP 1 | -- Parse all the Documents and group them by Period periods = initPeriods 5 3
$ both fst (head corpus,last corpus)
phyloDocs :: Map (Date, Date) [Document] foundations :: Vector Ngrams
phyloDocs = groupDocsByPeriod 5 3 (corpusToDocs corpus) (initNgrams actants) foundations = initFoundations actants
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
...@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.LevelMaker ...@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.LevelMaker
where where
import Control.Lens hiding (both, Level) import Control.Lens hiding (both, Level)
import Data.List ((++), sort, concat, nub, words, zip) import Data.List ((++), sort, concat, nub, words, zip, head, last)
import Data.Map (Map, (!), empty, restrictKeys, filterWithKey, singleton, union) import Data.Map (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
import Data.Set (Set) import Data.Set (Set)
import Data.Text (Text, words) import Data.Text (Text, words)
...@@ -27,6 +27,7 @@ import Data.Tuple.Extra ...@@ -27,6 +27,7 @@ import Data.Tuple.Extra
import Gargantext.Prelude hiding (head) import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo.Aggregates.Cluster import Gargantext.Viz.Phylo.Aggregates.Cluster
import Gargantext.Viz.Phylo.Aggregates.Cooc import Gargantext.Viz.Phylo.Aggregates.Cooc
import Gargantext.Viz.Phylo.Aggregates.Document
import Gargantext.Viz.Phylo import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.LinkMaker import Gargantext.Viz.Phylo.LinkMaker
...@@ -78,8 +79,8 @@ instance PhyloLevelMaker Document ...@@ -78,8 +79,8 @@ instance PhyloLevelMaker Document
-------------------------------------- --------------------------------------
-- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo -- | Level -> Map (Date,Date) [Document] -> Phylo -> Phylo
addPhyloLevel lvl m p addPhyloLevel lvl m p
| lvl < 0 = toPhyloLevel lvl m p | lvl == 0 = toPhyloLevel lvl m p
| otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> -1") | otherwise = panic ("[ERR][Viz.Phylo.Example.addPhyloLevel] No process declared for adding Documents at level <> 0")
-------------------------------------- --------------------------------------
-- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup] -- | Level -> (Date,Date) -> [Document] -> Map (Date,Date) [Fis] -> Phylo -> [PhyloGroup]
toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p) toPhyloGroups lvl (d,d') l m p = map (\(idx,ngram) -> ngramsToGroup (d,d') lvl idx ngram [ngram] p)
...@@ -113,7 +114,7 @@ cliqueToGroup prd lvl idx lbl fis m p = ...@@ -113,7 +114,7 @@ cliqueToGroup prd lvl idx lbl fis m p =
where where
-------------------------------------- --------------------------------------
ngrams :: [Int] ngrams :: [Int]
ngrams = sort $ map (\x -> ngramsToIdx x p) ngrams = sort $ map (\x -> getIdxInFoundations x p)
$ Set.toList $ Set.toList
$ fst fis $ fst fis
-------------------------------------- --------------------------------------
...@@ -126,7 +127,7 @@ cliqueToGroup prd lvl idx lbl fis m p = ...@@ -126,7 +127,7 @@ cliqueToGroup prd lvl idx lbl fis m p =
-- | To transform a list of Ngrams into a PhyloGroup -- | To transform a list of Ngrams into a PhyloGroup
ngramsToGroup :: PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup ngramsToGroup :: PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
ngramsToGroup prd lvl idx lbl ngrams p = ngramsToGroup prd lvl idx lbl ngrams p =
PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> ngramsToIdx x p) ngrams) empty empty [] [] [] [] PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInFoundations x p) ngrams) empty empty [] [] [] []
-- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups -- | To traverse a Phylo and add a new PhyloLevel linked to a new list of PhyloGroups
...@@ -140,14 +141,23 @@ toPhyloLevel lvl m p = alterPhyloPeriods ...@@ -140,14 +141,23 @@ toPhyloLevel lvl m p = alterPhyloPeriods
) period) p ) period) p
initPhylo :: Grain -> Step -> [(Date,Text)] -> [Ngrams] -> (Ngrams -> Ngrams) -> Phylo
initPhylo g s c a f = addPhyloLevel 0 (corpusToDocs f c base) base
where
--------------------------------------
base :: Phylo
base = initPhyloBase (initPeriods g s $ both fst (head c,last c)) (initFoundations a)
--------------------------------------
-- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks -- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks
toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo
toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p
| lvl >= lvlMax = p | lvl >= lvlMax = p
| otherwise = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) | otherwise = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
-- $ setPhyloBranches (lvl + 1)
$ pairGroupsToGroups Childs (lvl + 1) (prox',param3) $ pairGroupsToGroups Childs (lvl + 1) (prox',param3)
$ pairGroupsToGroups Parents (lvl + 1) (prox',param3) $ pairGroupsToGroups Parents (lvl + 1) (prox',param3)
$ setPhyloBranches (lvl + 1)
$ setLevelLinks (lvl, lvl + 1) $ setLevelLinks (lvl, lvl + 1)
$ addPhyloLevel (lvl + 1) $ addPhyloLevel (lvl + 1)
(phyloToClusters lvl (prox,param1) (clus,param2) p) p (phyloToClusters lvl (prox,param1) (clus,param2) p) p
......
...@@ -59,12 +59,6 @@ relatedComp idx curr (nodes,edges) next memo ...@@ -59,12 +59,6 @@ relatedComp idx curr (nodes,edges) next memo
-------------------------------------- --------------------------------------
{-
louvain :: (PhyloNodes,PhyloEdges) -> [Cluster]
louvain (nodes,edges) = undefined
-}
louvain :: (PhyloNodes,PhyloEdges) -> IO [[PhyloGroup]] louvain :: (PhyloNodes,PhyloEdges) -> IO [[PhyloGroup]]
louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community) louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
<$> groupBy (\a b -> (l_community_id a) == (l_community_id b)) <$> groupBy (\a b -> (l_community_id a) == (l_community_id b))
......
...@@ -59,8 +59,8 @@ alterPhyloPeriods f p = over ( phylo_periods ...@@ -59,8 +59,8 @@ alterPhyloPeriods f p = over ( phylo_periods
-- | To alter the list of PhyloBranches of a Phylo -- | To alter the list of PhyloBranches of a Phylo
alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo -- alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
alterPhyloBranches f p = over ( phylo_branches ) f p -- alterPhyloBranches f p = over ( phylo_branches ) f p
-- | To alter a list of PhyloLevels following a given function -- | To alter a list of PhyloLevels following a given function
...@@ -118,6 +118,18 @@ filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges ...@@ -118,6 +118,18 @@ filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges
-- | To get the foundations of a Phylo
getFoundations :: Phylo -> Vector Ngrams
getFoundations = _phylo_foundations
-- | To get the Index of a Ngrams in the Foundations of a Phylo
getIdxInFoundations :: Ngrams -> Phylo -> Int
getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getFoundationIdx] Ngrams not in Foundations"
Just idx -> idx
-- | To get the PhyloGroups Childs of a PhyloGroup -- | To get the PhyloGroups Childs of a PhyloGroup
getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup] getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
...@@ -193,13 +205,6 @@ getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p) ...@@ -193,13 +205,6 @@ getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
-- | To get all the PhyloGroup of a Phylo with a given Period -- | To get all the PhyloGroup of a Phylo with a given Period
getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup] getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p) getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
-- | To get the index of an element of a Vector
getIdx :: Eq a => a -> Vector a -> Int
getIdx x v = case (elemIndex x v) of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getIndex] Nothing"
Just i -> i
-- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c -- | To get the good pair of keys (x,y) or (y,x) in a given Map (a,b) c
...@@ -236,8 +241,8 @@ getNeighbours directed g e = case directed of ...@@ -236,8 +241,8 @@ getNeighbours directed g e = case directed of
-- | To get the Branches of a Phylo -- | To get the Branches of a Phylo
getPhyloBranches :: Phylo -> [PhyloBranch] -- getPhyloBranches :: Phylo -> [PhyloBranch]
getPhyloBranches = _phylo_branches -- getPhyloBranches = _phylo_branches
-- | To get the PhylolevelId of a given PhyloLevel -- | To get the PhylolevelId of a given PhyloLevel
...@@ -250,11 +255,6 @@ getPhyloLevels :: PhyloPeriod -> [PhyloLevel] ...@@ -250,11 +255,6 @@ getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
getPhyloLevels = view (phylo_periodLevels) getPhyloLevels = view (phylo_periodLevels)
-- | To get the Ngrams of a Phylo
getPhyloNgrams :: Phylo -> PhyloNgrams
getPhyloNgrams = _phylo_ngrams
-- | To get all the PhyloPeriodIds of a Phylo -- | To get all the PhyloPeriodIds of a Phylo
getPhyloPeriods :: Phylo -> [PhyloPeriodId] getPhyloPeriods :: Phylo -> [PhyloPeriodId]
getPhyloPeriods p = map _phylo_periodId getPhyloPeriods p = map _phylo_periodId
...@@ -266,26 +266,27 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId ...@@ -266,26 +266,27 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
getPhyloPeriodId prd = _phylo_periodId prd getPhyloPeriodId prd = _phylo_periodId prd
-- | To init the foundation of the Phylo as a Vector of Ngrams
initFoundations :: [Ngrams] -> Vector Ngrams
initFoundations l = Vector.fromList $ map toLower l
-- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters -- | To create a PhyloGroup in a Phylo out of a list of Ngrams and a set of parameters
initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
initGroup ngrams lbl idx lvl from to p = PhyloGroup initGroup ngrams lbl idx lvl from to p = PhyloGroup
(((from, to), lvl), idx) (((from, to), lvl), idx)
lbl lbl
(sort $ map (\x -> ngramsToIdx x p) ngrams) (sort $ map (\x -> getIdxInFoundations x p) ngrams)
(Map.empty) (Map.empty)
(Map.empty) (Map.empty)
[] [] [] [] [] [] [] []
-- | To init a PhyloNgrams as a Vector of Ngrams -- | To init the Base of a Phylo from a List of Periods and Foundations
initNgrams :: [Ngrams] -> PhyloNgrams initPhyloBase :: [(Date, Date)] -> Vector Ngrams -> Phylo
initNgrams l = Vector.fromList $ map toLower l initPhyloBase pds fds = Phylo ((fst . head) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds)
-- | To create a Phylo from a list of PhyloPeriods and Ngrams
initPhylo :: [(Date, Date)] -> PhyloNgrams -> Phylo
initPhylo l ngrams = Phylo ((fst . head) l, (snd . last) l) ngrams (map (\prd -> initPhyloPeriod prd []) l) []
-- | To create a PhyloLevel -- | To create a PhyloLevel
initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel initPhyloLevel :: PhyloLevelId -> [PhyloGroup] -> PhyloLevel
initPhyloLevel id groups = PhyloLevel id groups initPhyloLevel id groups = PhyloLevel id groups
...@@ -323,11 +324,6 @@ listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)] ...@@ -323,11 +324,6 @@ listToUnDirectedCombiWith :: forall a b. (a -> b) -> [a] -> [(b,b)]
listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ] listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l, y <- rest ]
-- | To transform an Ngrams into its corresponding index in a Phylo
ngramsToIdx :: Ngrams -> Phylo -> Int
ngramsToIdx x p = getIdx x (_phylo_ngrams p)
-- | To set the LevelId of a PhyloLevel and of all its PhyloGroups -- | To set the LevelId of a PhyloLevel and of all its PhyloGroups
setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel setPhyloLevelId :: Int -> PhyloLevel -> PhyloLevel
setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups) setPhyloLevelId lvl' (PhyloLevel (id, lvl) groups)
......
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