src/Gargantext/Database/Learn.hs

   1 {-|
   2 Module      : Gargantext.Database.Learn
   3 Description : Learn Small Data Analytics with big data connection (DB)
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE NoImplicitPrelude #-}
  13 {-# LANGUAGE QuasiQuotes       #-}
  14 {-# LANGUAGE RankNTypes        #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16 {-# LANGUAGE FlexibleContexts  #-}
  17 {-# LANGUAGE MonoLocalBinds    #-}
  18
  19 module Gargantext.Database.Learn where
  20
  21 import Data.Text (Text)
  22 import Data.Tuple (snd)
  23 import Data.Maybe
  24 import Gargantext.Database.Facet
  25 import Gargantext.Database.Types.Node
  26 import Gargantext.Prelude
  27 import Gargantext.Text.Learn
  28 import qualified Data.List as List
  29 import qualified Data.Text as Text
  30 import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
  31 --import Gargantext.Database.Utils (Cmd)
  32 --import Gargantext.Database.Schema.Node (HasNodeError)
  33 import Gargantext.API
  34 import Gargantext.API.Settings
  35 import Gargantext.Database.Flow (FlowCmdM)
  36
  37 data FavOrTrash = IsFav | IsTrash
  38   deriving (Eq)
  39
  40
  41
  42 --moreLike :: FlowCmdM env error m => FavOrTrash -> CorpusId -> m (Events Bool, [FacetDoc])
  43
  44
  45 moreLike :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [FacetDoc]
  46 moreLike ft cId = do
  47   priors <- getPriors ft cId
  48   moreLikeWith priors ft cId
  49
  50
  51 ---------------------------------------------------------------------------
  52 getPriors :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m (Events Bool)
  53 getPriors ft cId = do
  54   docs_trash <- runViewDocuments cId True Nothing Nothing Nothing
  55
  56   docs_fav   <- filter (\(FacetDoc _ _ _ _ f _) -> f == 2)
  57               <$> runViewDocuments cId False Nothing Nothing Nothing
  58
  59
  60   let priors = priorEventsWith text (fav2bool ft) (  List.zip (repeat False) docs_fav
  61                                       <> List.zip (repeat True ) docs_trash
  62                                       )
  63   pure priors
  64
  65
  66 moreLikeWith :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [FacetDoc]
  67 moreLikeWith priors ft cId = do
  68
  69   docs_test  <- filter (\(FacetDoc _ _ _ _ f _) -> f == 0)
  70               <$> runViewDocuments cId False Nothing Nothing Nothing
  71
  72   let results = map fst
  73        $ filter ((==) (Just $ not $ fav2bool ft) . snd)
  74        $ map (\f -> (f, detectDefaultWithPriors text priors f)) docs_test
  75
  76   pure results
  77
  78 ---------------------------------------------------------------------------
  79 fav2bool :: FavOrTrash -> Bool
  80 fav2bool ft = if (==) ft IsFav then True else False
  81
  82
  83 text :: FacetDoc -> Text
  84 text (FacetDoc _ _ _ h _ _)  = title <> "" <> Text.take 100 abstr
  85   where
  86     title = maybe "" identity (_hyperdataDocument_title    h)
  87     abstr = maybe "" identity (_hyperdataDocument_abstract h)
  88
  89 ---------------------------------------------------------------------------
  90
  91 apply :: (FlowCmdM DevEnv GargError m) => FavOrTrash -> CorpusId -> [NodeId] -> m [Int]
  92 apply favTrash cId ns = case favTrash of
  93       IsFav   -> nodeNodesCategory $ map (\n -> (cId, n, 2)) ns
  94       IsTrash -> nodeNodesCategory $ map (\n -> (cId, n, 0)) ns
  95
  96 moreLikeAndApply :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [Int]
  97 moreLikeAndApply ft cId = do
  98   priors <- getPriors ft cId
  99   moreLikeWithAndApply priors ft cId
 100
 101 moreLikeWithAndApply :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [Int]
 102 moreLikeWithAndApply priors ft cId = do
 103   ids <- map facetDoc_id <$> moreLikeWith priors ft cId
 104   apply ft cId ids
 105