Commit 25e6254d authored by Alexandre Delanoë's avatar Alexandre Delanoë

[FIX] Shared corpus in the same hierarchy for now

parent 4c6051cc
Pipeline #1274 failed with stage
...@@ -56,7 +56,6 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x) ...@@ -56,7 +56,6 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
-} -}
-- | TODO improve grouping functions of Authors, Sources, Institutes.. -- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists :: ( RepoCmdM env err m buildNgramsLists :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
...@@ -95,17 +94,20 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do ...@@ -95,17 +94,20 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
allTerms :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt allTerms :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet -- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists' :: FlowCont Text FlowListScores socialLists :: FlowCont Text FlowListScores
<- flowSocialList' MySelfFirst user nt ( FlowCont Map.empty <- flowSocialList MySelfFirst user nt ( FlowCont Map.empty
$ Map.fromList $ Map.fromList
$ List.zip (Map.keys allTerms) $ List.zip (Map.keys allTerms)
(List.cycle [mempty]) (List.cycle [mempty])
) )
let let
groupedWithList = toGroupedTree groupParams socialLists' allTerms groupedWithList = toGroupedTree groupParams socialLists allTerms
let let
(stopTerms, tailTerms) = Map.partition ((== Just StopTerm) . viewListType) $ view flc_scores groupedWithList (stopTerms, tailTerms) = Map.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList
(mapTerms, tailTerms') = Map.partition ((== Just MapTerm) . viewListType) tailTerms (mapTerms, tailTerms') = Map.partition ((== Just MapTerm) . viewListType) tailTerms
listSize = mapListSize - (List.length mapTerms) listSize = mapListSize - (List.length mapTerms)
...@@ -140,17 +142,21 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -140,17 +142,21 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
allTerms :: Map Text Double <- getTficf uCid mCid nt allTerms :: Map Text Double <- getTficf uCid mCid nt
-- | PrivateFirst for first developments since Public NodeMode is not implemented yet -- | PrivateFirst for first developments since Public NodeMode is not implemented yet
socialLists' :: FlowCont Text FlowListScores socialLists :: FlowCont Text FlowListScores
<- flowSocialList' MySelfFirst user nt ( FlowCont Map.empty <- flowSocialList MySelfFirst user nt ( FlowCont Map.empty
$ Map.fromList $ Map.fromList
$ List.zip (Map.keys allTerms) $ List.zip (Map.keys allTerms)
(List.cycle [mempty]) (List.cycle [mempty])
) )
let groupedWithList = toGroupedTree groupParams socialLists' allTerms
let groupedWithList = toGroupedTree groupParams socialLists allTerms
(stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType) (stopTerms, candidateTerms) = Map.partition ((== Just StopTerm) . viewListType)
$ view flc_scores groupedWithList $ view flc_scores groupedWithList
(groupedMono, groupedMult) = Map.partitionWithKey (\t _v -> size t < 2) candidateTerms (groupedMono, groupedMult) = Map.partitionWithKey (\t _v -> size t < 2) candidateTerms
-- printDebug "stopTerms" stopTerms
-- splitting monterms and multiterms to take proportional candidates -- splitting monterms and multiterms to take proportional candidates
let let
-- use % of list if to big, or Int if too small -- use % of list if to big, or Int if too small
...@@ -206,7 +212,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -206,7 +212,10 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
let let
groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Text)) groupedTreeScores_SpeGen :: Map Text (GroupedTreeScores (Scored Text))
groupedTreeScores_SpeGen = setScoresWithMap (mapScores identity) (groupedMonoHead <> groupedMultHead) groupedTreeScores_SpeGen = setScoresWithMap (mapScores identity)
( groupedMonoHead
<> groupedMultHead
)
let let
-- sort / partition / split -- sort / partition / split
...@@ -267,4 +276,6 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do ...@@ -267,4 +276,6 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
)] )]
] ]
-- printDebug "result" result
pure result pure result
...@@ -36,7 +36,7 @@ import Gargantext.Prelude ...@@ -36,7 +36,7 @@ import Gargantext.Prelude
data FlowSocialListPriority = MySelfFirst | OthersFirst data FlowSocialListPriority = MySelfFirst | OthersFirst
flowSocialListPriority :: FlowSocialListPriority -> [NodeMode] flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}] flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
...@@ -46,7 +46,7 @@ keepAllParents NgramsTerms = KeepAllParents False ...@@ -46,7 +46,7 @@ keepAllParents NgramsTerms = KeepAllParents False
keepAllParents _ = KeepAllParents True keepAllParents _ = KeepAllParents True
------------------------------------------------------------------------ ------------------------------------------------------------------------
flowSocialList' :: ( RepoCmdM env err m flowSocialList :: ( RepoCmdM env err m
, CmdM env err m , CmdM env err m
, HasNodeError err , HasNodeError err
, HasTreeError err , HasTreeError err
...@@ -55,7 +55,7 @@ flowSocialList' :: ( RepoCmdM env err m ...@@ -55,7 +55,7 @@ flowSocialList' :: ( RepoCmdM env err m
-> User -> NgramsType -> User -> NgramsType
-> FlowCont Text FlowListScores -> FlowCont Text FlowListScores
-> m (FlowCont Text FlowListScores) -> m (FlowCont Text FlowListScores)
flowSocialList' flowPriority user nt flc = flowSocialList flowPriority user nt flc =
mconcat <$> mapM (flowSocialListByMode' user nt flc) mconcat <$> mapM (flowSocialListByMode' user nt flc)
(flowSocialListPriority flowPriority) (flowSocialListPriority flowPriority)
where where
......
...@@ -38,7 +38,10 @@ findNodes' :: HasTreeError err ...@@ -38,7 +38,10 @@ findNodes' :: HasTreeError err
=> RootId => RootId
-> NodeMode -> NodeMode
-> Cmd err [DbTreeNode] -> Cmd err [DbTreeNode]
findNodes' r Private = findNodes r Private $ [NodeFolderPrivate] <> commonNodes findNodes' r Private = do
pv <- (findNodes r Private $ [NodeFolderPrivate] <> commonNodes)
sh <- (findNodes' r Shared)
pure $ pv <> sh
findNodes' r Shared = findNodes r Shared $ [NodeFolderShared, NodeTeam] <> commonNodes findNodes' r Shared = findNodes r Shared $ [NodeFolderShared, NodeTeam] <> commonNodes
findNodes' r Public = findNodes r Public $ [NodeFolderPublic ] <> commonNodes findNodes' r Public = findNodes r Public $ [NodeFolderPublic ] <> commonNodes
......
...@@ -36,6 +36,7 @@ data FlowCont a b = ...@@ -36,6 +36,7 @@ data FlowCont a b =
FlowCont { _flc_scores :: Map a b FlowCont { _flc_scores :: Map a b
, _flc_cont :: Map a b , _flc_cont :: Map a b
} }
deriving (Show)
instance (Ord a, Eq b) => Monoid (FlowCont a b) where instance (Ord a, Eq b) => Monoid (FlowCont a b) where
mempty = FlowCont mempty mempty mempty = FlowCont mempty mempty
......
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