Commit deee2cd3 authored by qlobbe's avatar qlobbe

merge with dev

parent 1cd9e5a1
Pipeline #3747 failed with stage
in 88 minutes and 29 seconds
...@@ -71,7 +71,7 @@ data SeaElevation = ...@@ -71,7 +71,7 @@ data SeaElevation =
instance ToSchema SeaElevation instance ToSchema SeaElevation
data Similarity = data PhyloSimilarity =
WeightedLogJaccard WeightedLogJaccard
{ _wlj_sensibility :: Double { _wlj_sensibility :: Double
, _wlj_minSharedNgrams :: Int } , _wlj_minSharedNgrams :: Int }
...@@ -84,7 +84,7 @@ data Similarity = ...@@ -84,7 +84,7 @@ data Similarity =
deriving (Show,Generic,Eq) deriving (Show,Generic,Eq)
instance ToSchema Similarity where instance ToSchema PhyloSimilarity where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
...@@ -179,7 +179,7 @@ data PhyloConfig = ...@@ -179,7 +179,7 @@ data PhyloConfig =
, listParser :: ListParser , listParser :: ListParser
, phyloName :: Text , phyloName :: Text
, phyloScale :: Int , phyloScale :: Int
, similarity :: Similarity , similarity :: PhyloSimilarity
, seaElevation :: SeaElevation , seaElevation :: SeaElevation
, defaultMode :: Bool , defaultMode :: Bool
, findAncestors :: Bool , findAncestors :: Bool
...@@ -253,8 +253,8 @@ instance ToJSON CorpusParser ...@@ -253,8 +253,8 @@ instance ToJSON CorpusParser
instance FromJSON ListParser instance FromJSON ListParser
instance ToJSON ListParser instance ToJSON ListParser
instance FromJSON Similarity instance FromJSON PhyloSimilarity
instance ToJSON Similarity instance ToJSON PhyloSimilarity
instance FromJSON SeaElevation instance FromJSON SeaElevation
instance ToJSON SeaElevation instance ToJSON SeaElevation
...@@ -601,7 +601,7 @@ instance ToSchema PhyloExport where ...@@ -601,7 +601,7 @@ instance ToSchema PhyloExport where
makeLenses ''PhyloConfig makeLenses ''PhyloConfig
makeLenses ''PhyloSubConfig makeLenses ''PhyloSubConfig
makeLenses ''Similarity makeLenses ''PhyloSimilarity
makeLenses ''SeaElevation makeLenses ''SeaElevation
makeLenses ''Quality makeLenses ''Quality
makeLenses ''Cluster makeLenses ''Cluster
......
...@@ -596,7 +596,7 @@ getGroupThr step g = ...@@ -596,7 +596,7 @@ getGroupThr step g =
breaks = (g ^. phylo_groupMeta) ! "breaks" breaks = (g ^. phylo_groupMeta) ! "breaks"
in (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl)) - step in (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl)) - step
toAncestor :: Double -> Map Int Double -> Similarity -> Double -> [PhyloGroup] -> PhyloGroup -> PhyloGroup toAncestor :: Double -> Map Int Double -> PhyloSimilarity -> Double -> [PhyloGroup] -> PhyloGroup -> PhyloGroup
toAncestor nbDocs diago similarity step candidates ego = toAncestor nbDocs diago similarity step candidates ego =
let curr = ego ^. phylo_groupAncestors let curr = ego ^. phylo_groupAncestors
in ego & phylo_groupAncestors .~ (curr ++ (map (\(g,w) -> (getGroupId g,w)) in ego & phylo_groupAncestors .~ (curr ++ (map (\(g,w) -> (getGroupId g,w))
...@@ -605,7 +605,7 @@ toAncestor nbDocs diago similarity step candidates ego = ...@@ -605,7 +605,7 @@ toAncestor nbDocs diago similarity step candidates ego =
$ filter (\g -> g ^. phylo_groupBranchId /= ego ^. phylo_groupBranchId ) candidates)) $ filter (\g -> g ^. phylo_groupBranchId /= ego ^. phylo_groupBranchId ) candidates))
headsToAncestors :: Double -> Map Int Double -> Similarity -> Double -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup] headsToAncestors :: Double -> Map Int Double -> PhyloSimilarity -> Double -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
headsToAncestors nbDocs diago similarity step heads acc = headsToAncestors nbDocs diago similarity step heads acc =
if (null heads) if (null heads)
then acc then acc
......
...@@ -406,14 +406,14 @@ getPeriodPointers fil g = ...@@ -406,14 +406,14 @@ getPeriodPointers fil g =
ToChildsMemory -> undefined ToChildsMemory -> undefined
ToParentsMemory -> undefined ToParentsMemory -> undefined
filterSimilarity :: Similarity -> Double -> Double -> Bool filterSimilarity :: PhyloSimilarity -> Double -> Double -> Bool
filterSimilarity similarity thr local = filterSimilarity similarity thr local =
case similarity of case similarity of
WeightedLogJaccard _ _ -> local >= thr WeightedLogJaccard _ _ -> local >= thr
WeightedLogSim _ _ -> local >= thr WeightedLogSim _ _ -> local >= thr
Hamming _ _ -> undefined Hamming _ _ -> undefined
getSimilarityName :: Similarity -> String getSimilarityName :: PhyloSimilarity -> String
getSimilarityName similarity = getSimilarityName similarity =
case similarity of case similarity of
WeightedLogJaccard _ _ -> "WLJaccard" WeightedLogJaccard _ _ -> "WLJaccard"
...@@ -474,7 +474,7 @@ getScales phylo = nub ...@@ -474,7 +474,7 @@ getScales phylo = nub
getSeaElevation :: Phylo -> SeaElevation getSeaElevation :: Phylo -> SeaElevation
getSeaElevation phylo = seaElevation (getConfig phylo) getSeaElevation phylo = seaElevation (getConfig phylo)
getSimilarity :: Phylo -> Similarity getSimilarity :: Phylo -> PhyloSimilarity
getSimilarity phylo = similarity (getConfig phylo) getSimilarity phylo = similarity (getConfig phylo)
...@@ -687,13 +687,13 @@ traceSynchronyStart phylo = ...@@ -687,13 +687,13 @@ traceSynchronyStart phylo =
-- | Similarity | -- -- | Similarity | --
------------------- -------------------
getSensibility :: Similarity -> Double getSensibility :: PhyloSimilarity -> Double
getSensibility proxi = case proxi of getSensibility proxi = case proxi of
WeightedLogJaccard s _ -> s WeightedLogJaccard s _ -> s
WeightedLogSim s _ -> s WeightedLogSim s _ -> s
Hamming _ _ -> undefined Hamming _ _ -> undefined
getMinSharedNgrams :: Similarity -> Int getMinSharedNgrams :: PhyloSimilarity -> Int
getMinSharedNgrams proxi = case proxi of getMinSharedNgrams proxi = case proxi of
WeightedLogJaccard _ m -> m WeightedLogJaccard _ m -> m
WeightedLogSim _ m -> m WeightedLogSim _ m -> m
......
...@@ -124,7 +124,7 @@ toDiamonds groups = foldl' (\acc groups' -> ...@@ -124,7 +124,7 @@ toDiamonds groups = foldl' (\acc groups' ->
$ foldl' (\acc g -> acc ++ (map (\(id,_) -> (id,[g]) ) $ g ^. phylo_groupPeriodParents) ) [] groups $ foldl' (\acc g -> acc ++ (map (\(id,_) -> (id,[g]) ) $ g ^. phylo_groupPeriodParents) ) [] groups
groupsToEdges :: Similarity -> Synchrony -> Double -> Map Int Double -> [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] groupsToEdges :: PhyloSimilarity -> Synchrony -> Double -> Map Int Double -> [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)]
groupsToEdges prox sync nbDocs diago groups = groupsToEdges prox sync nbDocs diago groups =
case sync of case sync of
ByProximityThreshold thr sens _ strat -> ByProximityThreshold thr sens _ strat ->
...@@ -153,7 +153,7 @@ toParentId :: PhyloGroup -> PhyloGroupId ...@@ -153,7 +153,7 @@ toParentId :: PhyloGroup -> PhyloGroupId
toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupScale + 1), child ^. phylo_groupIndex) toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupScale + 1), child ^. phylo_groupIndex)
reduceGroups :: Similarity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup] reduceGroups :: PhyloSimilarity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
reduceGroups prox sync docs diagos branch = reduceGroups prox sync docs diagos branch =
-- 1) reduce a branch as a set of periods & groups -- 1) reduce a branch as a set of periods & groups
let periods = fromListWith (++) let periods = fromListWith (++)
......
...@@ -119,7 +119,7 @@ weightedLogSim' sens nbDocs diago ego_ngrams target_ngrams ...@@ -119,7 +119,7 @@ weightedLogSim' sens nbDocs diago ego_ngrams target_ngrams
{- {-
-- perform a seamilarity measure between a given group and a pair of targeted groups -- perform a seamilarity measure between a given group and a pair of targeted groups
-} -}
toSimilarity :: Double -> Map Int Double -> Similarity -> [Int] -> [Int] -> [Int] -> Double toSimilarity :: Double -> Map Int Double -> PhyloSimilarity -> [Int] -> [Int] -> [Int] -> Double
toSimilarity nbDocs diago similarity egoNgrams targetNgrams targetNgrams' = toSimilarity nbDocs diago similarity egoNgrams targetNgrams targetNgrams' =
case similarity of case similarity of
WeightedLogJaccard sens _ -> WeightedLogJaccard sens _ ->
...@@ -147,7 +147,7 @@ findLastPeriod fil periods = case fil of ...@@ -147,7 +147,7 @@ findLastPeriod fil periods = case fil of
ToChildsMemory -> undefined ToChildsMemory -> undefined
ToParentsMemory -> undefined ToParentsMemory -> undefined
removeOldPointers :: [Pointer] -> Filiation -> Double -> Similarity -> Period removeOldPointers :: [Pointer] -> Filiation -> Double -> PhyloSimilarity -> Period
-> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
-> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
removeOldPointers oldPointers fil thr prox prd pairs removeOldPointers oldPointers fil thr prox prd pairs
...@@ -166,10 +166,10 @@ removeOldPointers oldPointers fil thr prox prd pairs ...@@ -166,10 +166,10 @@ removeOldPointers oldPointers fil thr prox prd pairs
|| (((fst . fst . fst) id') > (fst lastMatchedPrd))) pairs || (((fst . fst . fst) id') > (fst lastMatchedPrd))) pairs
| otherwise = [] | otherwise = []
filterPointers :: Similarity -> Double -> [Pointer] -> [Pointer] filterPointers :: PhyloSimilarity -> Double -> [Pointer] -> [Pointer]
filterPointers proxi thr pts = filter (\(_,w) -> filterSimilarity proxi thr w) pts filterPointers proxi thr pts = filter (\(_,w) -> filterSimilarity proxi thr w) pts
filterPointers' :: Similarity -> Double -> [(Pointer,[Int])] -> [(Pointer,[Int])] filterPointers' :: PhyloSimilarity -> Double -> [(Pointer,[Int])] -> [(Pointer,[Int])]
filterPointers' proxi thr pts = filter (\((_,w),_) -> filterSimilarity proxi thr w) pts filterPointers' proxi thr pts = filter (\((_,w),_) -> filterSimilarity proxi thr w) pts
...@@ -231,7 +231,7 @@ groupsToBranches groups = ...@@ -231,7 +231,7 @@ groupsToBranches groups =
{- {-
-- find the best pair/singleton of parents/childs for a given group -- find the best pair/singleton of parents/childs for a given group
-} -}
makePairs :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [Period] -> [Pointer] -> Filiation -> Double -> Similarity makePairs :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [Period] -> [Pointer] -> Filiation -> Double -> PhyloSimilarity
-> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos = makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos =
if (null periods) if (null periods)
...@@ -258,7 +258,7 @@ makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs di ...@@ -258,7 +258,7 @@ makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs di
{- {-
-- find the best temporal links between a given group and its parents/childs -- find the best temporal links between a given group and its parents/childs
-} -}
phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Similarity -> Map Date Double -> Map Date Cooc phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> PhyloSimilarity -> Map Date Double -> Map Date Cooc
-> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer] -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
phyloGroupMatching candidates filiation proxi docs diagos thr oldPointers (id,ngrams) = phyloGroupMatching candidates filiation proxi docs diagos thr oldPointers (id,ngrams) =
if (null $ filterPointers proxi thr oldPointers) if (null $ filterPointers proxi thr oldPointers)
...@@ -329,7 +329,7 @@ getCandidates minNgrams ego targets = ...@@ -329,7 +329,7 @@ getCandidates minNgrams ego targets =
{- {-
-- set up and start performing the upstream/downstream inter‐temporal matching period by period -- set up and start performing the upstream/downstream inter‐temporal matching period by period
-} -}
reconstructTemporalLinks :: Int -> [Period] -> Similarity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup] reconstructTemporalLinks :: Int -> [Period] -> PhyloSimilarity -> Double -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
reconstructTemporalLinks frame periods similarity thr docs coocs groups = reconstructTemporalLinks frame periods similarity thr docs coocs groups =
let groups' = groupByField _phylo_groupPeriod groups let groups' = groupByField _phylo_groupPeriod groups
in foldl' (\acc prd -> in foldl' (\acc prd ->
...@@ -396,7 +396,7 @@ filterByNgrams inf ngrams groups = ...@@ -396,7 +396,7 @@ filterByNgrams inf ngrams groups =
{- {-
-- perform the upstream/downstream inter‐temporal matching process group by group -- perform the upstream/downstream inter‐temporal matching process group by group
-} -}
reconstructTemporalLinks' :: Int -> [Period] -> Similarity -> Double -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [PhyloGroup] -> [PhyloGroup] reconstructTemporalLinks' :: Int -> [Period] -> PhyloSimilarity -> Double -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [PhyloGroup] -> [PhyloGroup]
reconstructTemporalLinks' frame periods similarity thr docs coocs roots groups = reconstructTemporalLinks' frame periods similarity thr docs coocs roots groups =
let egos = map (\ego -> let egos = map (\ego ->
let -- 1) find the parents/childs matching periods let -- 1) find the parents/childs matching periods
...@@ -432,7 +432,7 @@ reconstructTemporalLinks' frame periods similarity thr docs coocs roots groups = ...@@ -432,7 +432,7 @@ reconstructTemporalLinks' frame periods similarity thr docs coocs roots groups =
{- {-
-- reconstruct a phylomemetic network from a list of groups and from a given threshold -- reconstruct a phylomemetic network from a list of groups and from a given threshold
-} -}
toPhylomemeticNetwork :: Int -> [Period] -> Similarity -> Double -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [PhyloGroup] -> [Branch] toPhylomemeticNetwork :: Int -> [Period] -> PhyloSimilarity -> Double -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [PhyloGroup] -> [Branch]
toPhylomemeticNetwork timescale periods similarity thr docs coocs roots groups = toPhylomemeticNetwork timescale periods similarity thr docs coocs roots groups =
groupsToBranches $ fromList $ map (\g -> (getGroupId g, g)) groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
-- $ reconstructTemporalLinks timescale periods similarity thr docs coocs groups -- $ reconstructTemporalLinks timescale periods similarity thr docs coocs groups
...@@ -592,7 +592,7 @@ thrToMeta thr branches = ...@@ -592,7 +592,7 @@ thrToMeta thr branches =
-- done = all the already separated branches -- done = all the already separated branches
-- rest = all the branches we still have to separate -- rest = all the branches we still have to separate
-} -}
separateBranches :: Double -> Similarity -> Double -> Map Int Double -> Int -> Double -> Double separateBranches :: Double -> PhyloSimilarity -> Double -> Map Int Double -> Int -> Double -> Double
-> Int -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [Period] -> Int -> Map Date Double -> Map Date Cooc -> Map Int [PhyloGroupId] -> [Period]
-> [(Branch,ShouldTry)] -> (Branch,ShouldTry) -> [(Branch,ShouldTry)] -> [(Branch,ShouldTry)] -> (Branch,ShouldTry) -> [(Branch,ShouldTry)]
-> [(Branch,ShouldTry)] -> [(Branch,ShouldTry)]
...@@ -647,7 +647,7 @@ separateBranches fdt similarity lambda frequency minBranch thr rise timescale do ...@@ -647,7 +647,7 @@ separateBranches fdt similarity lambda frequency minBranch thr rise timescale do
{- {-
-- perform the sea-level rise algorithm, browse the similarity ladder and check that we can try out the next step -- perform the sea-level rise algorithm, browse the similarity ladder and check that we can try out the next step
-} -}
seaLevelRise :: Double -> Similarity -> Double -> Int -> Map Int Double seaLevelRise :: Double -> PhyloSimilarity -> Double -> Int -> Map Int Double
-> [Double] -> Double -> [Double] -> Double
-> Int -> [Period] -> Int -> [Period]
-> Map Date Double -> Map Date Cooc -> Map Date Double -> Map Date Cooc
......
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