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

[LEARN API]

parent ae1c032e
...@@ -99,18 +99,22 @@ instance ToParamSchema TODO where ...@@ -99,18 +99,22 @@ instance ToParamSchema TODO where
------------------------------------------------------------------------ ------------------------------------------------------------------------
--data FacetFormat = Table | Chart --data FacetFormat = Table | Chart
data TabType = Docs | Terms | Sources | Authors | Institutes | Trash data TabType = Docs | Trash | MoreFav | MoreTrash
| Terms | Sources | Authors | Institutes
| Contacts | Contacts
deriving (Generic, Enum, Bounded) deriving (Generic, Enum, Bounded)
instance FromHttpApiData TabType instance FromHttpApiData TabType
where where
parseUrlPiece "Docs" = pure Docs parseUrlPiece "Docs" = pure Docs
parseUrlPiece "Trash" = pure Trash
parseUrlPiece "MoreFav" = pure MoreFav
parseUrlPiece "MoreTrash" = pure MoreTrash
parseUrlPiece "Terms" = pure Terms parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Institutes" = pure Institutes parseUrlPiece "Institutes" = pure Institutes
parseUrlPiece "Authors" = pure Authors parseUrlPiece "Authors" = pure Authors
parseUrlPiece "Trash" = pure Trash
parseUrlPiece "Contacts" = pure Contacts parseUrlPiece "Contacts" = pure Contacts
......
...@@ -33,7 +33,6 @@ import qualified Data.Set as Set ...@@ -33,7 +33,6 @@ import qualified Data.Set as Set
type RootTerm = Text type RootTerm = Text
getListNgrams :: RepoCmdM env err m getListNgrams :: RepoCmdM env err m
=> [ListId] -> NgramsType => [ListId] -> NgramsType
-> m (Map Text NgramsRepoElement) -> m (Map Text NgramsRepoElement)
...@@ -68,7 +67,7 @@ mapTermListRoot :: RepoCmdM env err m ...@@ -68,7 +67,7 @@ mapTermListRoot :: RepoCmdM env err m
-> m (Map Text (ListType, (Maybe Text))) -> m (Map Text (ListType, (Maybe Text)))
mapTermListRoot nodeIds ngramsType = do mapTermListRoot nodeIds ngramsType = do
ngrams <- getListNgrams nodeIds ngramsType ngrams <- getListNgrams nodeIds ngramsType
pure $ Map.fromList [(t, (_nre_list nre, _nre_root nre)) pure $ Map.fromList [ (t, (_nre_list nre, _nre_root nre))
| (t, nre) <- Map.toList ngrams | (t, nre) <- Map.toList ngrams
] ]
...@@ -104,14 +103,12 @@ getCoocByNgrams = getCoocByNgrams' identity ...@@ -104,14 +103,12 @@ getCoocByNgrams = getCoocByNgrams' identity
getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (a, a) Int getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (a, a) Int
getCoocByNgrams' f (Diagonal diag) m = getCoocByNgrams' f (Diagonal diag) m =
Map.fromList [((t1,t2) Map.fromList [( (t1,t2)
,maybe 0 Set.size $ Set.intersection , maybe 0 Set.size $ Set.intersection
<$> (fmap f $ Map.lookup t1 m) <$> (fmap f $ Map.lookup t1 m)
<*> (fmap f $ Map.lookup t2 m) <*> (fmap f $ Map.lookup t2 m)
) | (t1,t2) <- case diag of ) | (t1,t2) <- case diag of
True -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y] True -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y]
False -> listToCombi identity (Map.keys m) False -> listToCombi identity (Map.keys m)
] ]
...@@ -63,6 +63,7 @@ import Gargantext.Database.Schema.NodeNode (nodeNodesCategory) ...@@ -63,6 +63,7 @@ import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
import Gargantext.Database.Tree (treeDB) import Gargantext.Database.Tree (treeDB)
import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node
import Gargantext.Database.Utils -- (Cmd, CmdM) import Gargantext.Database.Utils -- (Cmd, CmdM)
import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Prelude.Utils (hash) import Gargantext.Prelude.Utils (hash)
import Gargantext.Viz.Chart import Gargantext.Viz.Chart
...@@ -329,6 +330,8 @@ getTable cId ft o l order = ...@@ -329,6 +330,8 @@ getTable cId ft o l order =
case ft of case ft of
(Just Docs) -> runViewDocuments cId False o l order (Just Docs) -> runViewDocuments cId False o l order
(Just Trash) -> runViewDocuments cId True o l order (Just Trash) -> runViewDocuments cId True o l order
(Just MoreFav) -> moreLike cId o l order IsFav
(Just MoreTrash) -> moreLike cId o l order IsTrash
_ -> panic "not implemented" _ -> panic "not implemented"
getPairing :: ContactId -> Maybe TabType getPairing :: ContactId -> Maybe TabType
......
...@@ -27,27 +27,22 @@ import Gargantext.Prelude ...@@ -27,27 +27,22 @@ import Gargantext.Prelude
import Gargantext.Text.Learn import Gargantext.Text.Learn
import qualified Data.List as List import qualified Data.List as List
import qualified Data.Text as Text import qualified Data.Text as Text
import Gargantext.Database.Schema.NodeNode (nodeNodesCategory) --import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
--import Gargantext.Database.Utils (Cmd) import Gargantext.Database.Utils (Cmd)
--import Gargantext.Database.Schema.Node (HasNodeError) import Gargantext.Core.Types (Offset, Limit)
import Gargantext.API
import Gargantext.API.Settings
import Gargantext.Database.Flow (FlowCmdM)
data FavOrTrash = IsFav | IsTrash data FavOrTrash = IsFav | IsTrash
deriving (Eq) deriving (Eq)
--moreLike :: FlowCmdM env error m => FavOrTrash -> CorpusId -> m (Events Bool, [FacetDoc]) moreLike :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> Cmd err [FacetDoc]
moreLike :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [FacetDoc] moreLike cId o l order ft = do
moreLike ft cId = do
priors <- getPriors ft cId priors <- getPriors ft cId
moreLikeWith priors ft cId moreLikeWith cId o l order ft priors
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
getPriors :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m (Events Bool) getPriors :: FavOrTrash -> CorpusId -> Cmd err (Events Bool)
getPriors ft cId = do getPriors ft cId = do
docs_trash <- runViewDocuments cId True Nothing Nothing Nothing docs_trash <- runViewDocuments cId True Nothing Nothing Nothing
...@@ -61,11 +56,12 @@ getPriors ft cId = do ...@@ -61,11 +56,12 @@ getPriors ft cId = do
pure priors pure priors
moreLikeWith :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [FacetDoc] moreLikeWith :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
moreLikeWith priors ft cId = do -> FavOrTrash -> Events Bool -> Cmd err [FacetDoc]
moreLikeWith cId o l order ft priors = do
docs_test <- filter (\(FacetDoc _ _ _ _ f _) -> f == 0) docs_test <- filter (\(FacetDoc _ _ _ _ f _) -> f == 0)
<$> runViewDocuments cId False Nothing Nothing Nothing <$> runViewDocuments cId False o l order
let results = map fst let results = map fst
$ filter ((==) (Just $ not $ fav2bool ft) . snd) $ filter ((==) (Just $ not $ fav2bool ft) . snd)
...@@ -86,7 +82,8 @@ text (FacetDoc _ _ _ h _ _) = title <> "" <> Text.take 100 abstr ...@@ -86,7 +82,8 @@ text (FacetDoc _ _ _ h _ _) = title <> "" <> Text.take 100 abstr
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
apply :: (FlowCmdM DevEnv GargError m) => FavOrTrash -> CorpusId -> [NodeId] -> m [Int] {-
apply :: (FlowCmdM env e m) => FavOrTrash -> CorpusId -> [NodeId] -> m [Int]
apply favTrash cId ns = case favTrash of apply favTrash cId ns = case favTrash of
IsFav -> nodeNodesCategory $ map (\n -> (cId, n, 2)) ns IsFav -> nodeNodesCategory $ map (\n -> (cId, n, 2)) ns
IsTrash -> nodeNodesCategory $ map (\n -> (cId, n, 0)) ns IsTrash -> nodeNodesCategory $ map (\n -> (cId, n, 0)) ns
...@@ -98,6 +95,6 @@ moreLikeAndApply ft cId = do ...@@ -98,6 +95,6 @@ moreLikeAndApply ft cId = do
moreLikeWithAndApply :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [Int] moreLikeWithAndApply :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [Int]
moreLikeWithAndApply priors ft cId = do moreLikeWithAndApply priors ft cId = do
ids <- map facetDoc_id <$> moreLikeWith priors ft cId ids <- map facetDoc_id <$> moreLikeWith cId ft priors
apply ft cId ids apply ft cId ids
-}
...@@ -35,7 +35,6 @@ import Gargantext.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-}) ...@@ -35,7 +35,6 @@ import Gargantext.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import qualified Data.Map as Map import qualified Data.Map as Map
--import qualified Data.Vector.Storable as Vec --import qualified Data.Vector.Storable as Vec
getMetrics :: FlowCmdM env err m getMetrics :: FlowCmdM env err m
=> CorpusId -> Maybe ListId -> TabType -> Maybe Limit => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
-> m (Map Text (ListType, Maybe Text), [Scored Text]) -> m (Map Text (ListType, Maybe Text), [Scored Text])
...@@ -72,6 +71,7 @@ getNgrams :: (FlowCmdM env err m) ...@@ -72,6 +71,7 @@ getNgrams :: (FlowCmdM env err m)
=> CorpusId -> Maybe ListId -> TabType => CorpusId -> Maybe ListId -> TabType
-> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm)) -> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm))
getNgrams cId maybeListId tabType = do getNgrams cId maybeListId tabType = do
lId <- case maybeListId of lId <- case maybeListId of
Nothing -> defaultList cId Nothing -> defaultList cId
Just lId' -> pure lId' Just lId' -> pure lId'
......
...@@ -298,10 +298,6 @@ getNodesByNgramsMaster ucId mcId = Map.unionsWith (<>) ...@@ -298,10 +298,6 @@ getNodesByNgramsMaster ucId mcId = Map.unionsWith (<>)
<$> mapM (selectNgramsByNodeMaster 1000 ucId mcId) [0,500..10000] <$> mapM (selectNgramsByNodeMaster 1000 ucId mcId) [0,500..10000]
type Limit = Int
type Offset = Int
selectNgramsByNodeMaster :: Int -> UserCorpusId -> MasterCorpusId -> Int -> Cmd err [(NodeId, Text)] selectNgramsByNodeMaster :: Int -> UserCorpusId -> MasterCorpusId -> Int -> Cmd err [(NodeId, Text)]
selectNgramsByNodeMaster n ucId mcId p = runPGSQuery selectNgramsByNodeMaster n ucId mcId p = runPGSQuery
queryNgramsByNodeMaster' queryNgramsByNodeMaster'
......
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