Commit a8d05287 authored by Alexandre Delanoë's avatar Alexandre Delanoë

[WIP] connecting Ngrams Terms flow with social list

parent 501553c6
Pipeline #1241 failed with stage
...@@ -153,8 +153,9 @@ buildNgramsTermsList user uCid mCid groupParams = do ...@@ -153,8 +153,9 @@ buildNgramsTermsList user uCid mCid groupParams = do
groupedWithList = map (addListType (invertForw socialLists)) grouped groupedWithList = map (addListType (invertForw socialLists)) grouped
(stopTerms, candidateTerms) = Map.partition (\t -> t ^. gt_listType == Just StopTerm) groupedWithList (stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType) groupedWithList
(groupedMono, groupedMult) = Map.partition (\t -> t ^. gt_size < 2) candidateTerms (groupedMono, groupedMult) = Map.partition (\t -> t ^. gt_size < 2) candidateTerms
-- (groupedMono, groupedMult) = Map.partitionWithKey (\t -> t ^. gt_size < 2) candidateTerms
-- printDebug "\n * stopTerms * \n" stopTerms -- printDebug "\n * stopTerms * \n" stopTerms
-- splitting monterms and multiterms to take proportional candidates -- splitting monterms and multiterms to take proportional candidates
...@@ -180,8 +181,9 @@ buildNgramsTermsList user uCid mCid groupParams = do ...@@ -180,8 +181,9 @@ buildNgramsTermsList user uCid mCid groupParams = do
(\set' (GroupedText _ l' _ g _ _ _ ) -> Set.union set' (\set' (GroupedText _ l' _ g _ _ _ ) -> Set.union set'
$ Set.insert l' g $ Set.insert l' g
) )
Set.empty Set.empty
(groupedMonoHead <> groupedMultHead) (groupedMonoHead <> groupedMultHead)
-- selectedTerms = hasTerms (groupedMonoHead <> groupedMultHead)
-- TO remove (and remove HasNodeError instance) -- TO remove (and remove HasNodeError instance)
userListId <- defaultList uCid userListId <- defaultList uCid
...@@ -243,7 +245,7 @@ buildNgramsTermsList user uCid mCid groupParams = do ...@@ -243,7 +245,7 @@ buildNgramsTermsList user uCid mCid groupParams = do
-- filter mono/multi again -- filter mono/multi again
(monoScored, multScored) = List.partition (\g -> _gt_size g < 2) groupsWithScores (monoScored, multScored) = List.partition (\g -> _gt_size g < 2) groupsWithScores
-- filter with max score -- filter with max score
partitionWithMaxScore = List.partition (\g -> let (s1,s2) = _gt_score g in s1 > s2 ) partitionWithMaxScore = List.partition (\g -> let (s1,s2) = viewScore g in s1 > s2 )
(monoScoredIncl, monoScoredExcl) = partitionWithMaxScore monoScored (monoScoredIncl, monoScoredExcl) = partitionWithMaxScore monoScored
(multScoredIncl, multScoredExcl) = partitionWithMaxScore multScored (multScoredIncl, multScoredExcl) = partitionWithMaxScore multScored
...@@ -255,29 +257,29 @@ buildNgramsTermsList user uCid mCid groupParams = do ...@@ -255,29 +257,29 @@ buildNgramsTermsList user uCid mCid groupParams = do
exclSize = 1 - inclSize exclSize = 1 - inclSize
splitAt' n' = List.splitAt (round $ n' * listSizeLocal) splitAt' n' = List.splitAt (round $ n' * listSizeLocal)
(monoScoredInclHead, monoScoredInclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . _gt_score) monoScoredIncl (monoScoredInclHead, monoScoredInclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . viewScore) monoScoredIncl
(monoScoredExclHead, monoScoredExclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . _gt_score) monoScoredExcl (monoScoredExclHead, monoScoredExclTail) = splitAt' (monoSize * inclSize / 2) $ List.sortOn (Down . viewScore) monoScoredExcl
(multScoredInclHead, multScoredInclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . _gt_score) multScoredIncl (multScoredInclHead, multScoredInclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . viewScore) multScoredIncl
(multScoredExclHead, multScoredExclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . _gt_score) multScoredExcl (multScoredExclHead, multScoredExclTail) = splitAt' (multSize * exclSize / 2) $ List.sortOn (Down . viewScore) multScoredExcl
-- Final Step building the Typed list -- Final Step building the Typed list
termListHead = maps <> cands termListHead = maps <> cands
where where
maps = set gt_listType (Just MapTerm) maps = setListType (Just MapTerm)
<$> monoScoredInclHead <$> monoScoredInclHead
<> monoScoredExclHead <> monoScoredExclHead
<> multScoredInclHead <> multScoredInclHead
<> multScoredExclHead <> multScoredExclHead
cands = set gt_listType (Just CandidateTerm) cands = setListType (Just CandidateTerm)
<$> monoScoredInclTail <$> monoScoredInclTail
<> monoScoredExclTail <> monoScoredExclTail
<> multScoredInclTail <> multScoredInclTail
<> multScoredExclTail <> multScoredExclTail
termListTail = map (set gt_listType (Just CandidateTerm)) ( groupedMonoTail <> groupedMultTail) termListTail = map (setListType (Just CandidateTerm)) ( groupedMonoTail <> groupedMultTail)
-- printDebug "monoScoredInclHead" monoScoredInclHead -- printDebug "monoScoredInclHead" monoScoredInclHead
-- printDebug "monoScoredExclHead" monoScoredExclTail -- printDebug "monoScoredExclHead" monoScoredExclTail
......
...@@ -65,6 +65,9 @@ class SetListType a where ...@@ -65,6 +65,9 @@ class SetListType a where
class Ord b => ViewScore a b | a -> b where class Ord b => ViewScore a b | a -> b where
viewScore :: a -> b viewScore :: a -> b
class ViewScores a b | a -> b where
viewScores :: a -> b
class ToNgramsElement a where class ToNgramsElement a where
toNgramsElement :: a -> [NgramsElement] toNgramsElement :: a -> [NgramsElement]
...@@ -82,12 +85,29 @@ instance SetListType (GroupedTreeScores a) where ...@@ -82,12 +85,29 @@ instance SetListType (GroupedTreeScores a) where
instance SetListType (Map Text (GroupedTreeScores a)) where instance SetListType (Map Text (GroupedTreeScores a)) where
setListType lt = Map.map (set gts'_listType lt) setListType lt = Map.map (set gts'_listType lt)
------
instance ViewScore (GroupedTreeScores (Set NodeId)) Int where instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
viewScore = Set.size . (view gts'_score) viewScore = Set.size . viewScores
instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where
viewScores g = Set.unions $ parent : children
where
parent = view gts'_score g
children = map viewScores $ Map.elems $ view gts'_children g
------
instance HasTerms (Map Text (GroupedTreeScores a)) where instance HasTerms (Map Text (GroupedTreeScores a)) where
hasTerms = undefined hasTerms = Set.unions . (map hasTerms) . Map.toList
instance HasTerms (Text, GroupedTreeScores a) where
hasTerms (t, g) = Set.singleton t <> children
where
children = Set.unions
$ map hasTerms
$ Map.toList
$ view gts'_children g
------
instance ToNgramsElement (Map Text (GroupedTreeScores a)) where instance ToNgramsElement (Map Text (GroupedTreeScores a)) where
toNgramsElement = List.concat . (map toNgramsElement) . Map.toList toNgramsElement = List.concat . (map toNgramsElement) . Map.toList
......
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