Commit bf5360f9 authored by Quentin Lobbé's avatar Quentin Lobbé

fix some bugs

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