Commit a7057221 authored by qlobbe's avatar qlobbe

bug fix

parent e5935d9c
...@@ -160,7 +160,7 @@ toDotEdge source target lbl edgeType = edge source target ...@@ -160,7 +160,7 @@ toDotEdge source target lbl edgeType = edge source target
mergePointers :: [PhyloGroup] -> Map (PhyloGroupId,PhyloGroupId) Double mergePointers :: [PhyloGroup] -> Map (PhyloGroupId,PhyloGroupId) Double
mergePointers groups = mergePointers groups =
let toChilds = fromList $ concat $ map (\g -> map (\(target,w) -> ((getGroupId g,target),w)) $ g ^. phylo_groupPeriodChilds) groups let toChilds = fromList $ concat $ map (\g -> map (\(target,w) -> ((getGroupId g,target),w)) $ g ^. phylo_groupPeriodChilds) groups
toParents = fromList $ concat $ map (\g -> map (\(target,w) -> ((target,getGroupId g),w)) $ g ^. phylo_groupPeriodParents) groups toParents = fromList $ concat $ map (\g -> map (\(target,w) -> ((getGroupId g,target),w)) $ g ^. phylo_groupPeriodParents) groups
in unionWith (\w w' -> max w w') toChilds toParents in unionWith (\w w' -> max w w') toChilds toParents
......
...@@ -206,7 +206,7 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of ...@@ -206,7 +206,7 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
$ foldl sumCooc empty $ foldl sumCooc empty
$ map listToMatrix $ map listToMatrix
$ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques 0 cooc)) in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques 0.1 cooc))
$ toList phyloDocs $ toList phyloDocs
mcl' = mcl `using` parList rdeepseq mcl' = mcl `using` parList rdeepseq
in fromList mcl' in fromList mcl'
......
...@@ -144,6 +144,13 @@ reduceDiagos :: Map Date Cooc -> Map Int Double ...@@ -144,6 +144,13 @@ reduceDiagos :: Map Date Cooc -> Map Int Double
reduceDiagos diagos = mapKeys (\(k,_) -> k) reduceDiagos diagos = mapKeys (\(k,_) -> k)
$ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos) $ foldl (\acc diago -> unionWith (+) acc diago) empty (elems diagos)
filterPointersByPeriod :: [Pointer] -> [Pointer]
filterPointersByPeriod pts =
let pts' = sortOn (fst . fst . fst) pts
inf = (fst . fst . fst) $ head' "filterPointersByPeriod" pts'
sup = (fst . fst . fst) $ last' "filterPointersByPeriod" pts'
in nub
$ filter (\pt -> ((fst . fst . fst) pt == inf) || ((fst . fst . fst) pt == sup)) pts'
phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc
-> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer] -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
...@@ -152,7 +159,8 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams) ...@@ -152,7 +159,8 @@ phyloGroupMatching candidates fil proxi docs diagos thr oldPointers (id,ngrams)
-- | let's find new pointers -- | let's find new pointers
then if null nextPointers then if null nextPointers
then [] then []
else head' "phyloGroupMatching" else filterPointersByPeriod
$ head' "phyloGroupMatching"
-- | Keep only the best set of pointers grouped by proximity -- | Keep only the best set of pointers grouped by proximity
$ groupBy (\pt pt' -> snd pt == snd pt') $ groupBy (\pt pt' -> snd pt == snd pt')
$ reverse $ sortOn snd $ head' "pointers" nextPointers $ reverse $ sortOn snd $ head' "pointers" nextPointers
......
...@@ -116,7 +116,6 @@ listToEqualCombi l = [(x,y) | x <- l, y <- l, x == y] ...@@ -116,7 +116,6 @@ listToEqualCombi l = [(x,y) | x <- l, y <- l, x == y]
listToPairs :: Eq a => [a] -> [(a,a)] listToPairs :: Eq a => [a] -> [(a,a)]
listToPairs l = (listToEqualCombi l) ++ (listToUnDirectedCombi l) listToPairs l = (listToEqualCombi l) ++ (listToUnDirectedCombi l)
-- | To get all combinations of a list and apply a function to the resulting list of pairs -- | To get all combinations of a list and apply a function to the resulting list of pairs
listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)] listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y] listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
......
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