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 (nodesToFavorite)
  31 import Gargantext.API.Node (delDocs, Documents(..))
  32 --import Gargantext.Database.Utils (Cmd)
  33 --import Gargantext.Database.Schema.Node (HasNodeError)
  34 import Gargantext.API
  35 import Gargantext.API.Settings
  36 import Gargantext.Database.Flow (FlowCmdM)
  37
  38 data FavOrTrash = IsFav | IsTrash
  39   deriving (Eq)
  40
  41
  42
  43 --moreLike :: FlowCmdM env error m => FavOrTrash -> CorpusId -> m (Events Bool, [FacetDoc])
  44
  45
  46 moreLike :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [FacetDoc]
  47 moreLike ft cId = do
  48   priors <- getPriors ft cId
  49   moreLikeWith priors ft cId
  50
  51
  52 ---------------------------------------------------------------------------
  53 getPriors :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m (Events Bool)
  54 getPriors ft cId = do
  55   docs_trash <- runViewDocuments cId True Nothing Nothing Nothing
  56
  57   docs_fav   <- filter (\(FacetDoc _ _ _ _ f _) -> f == True)
  58               <$> runViewDocuments cId False Nothing Nothing Nothing
  59
  60
  61   let priors = priorEventsWith text (fav2bool ft) (  List.zip (repeat False) docs_fav
  62                                       <> List.zip (repeat True ) docs_trash
  63                                       )
  64   pure priors
  65
  66
  67 moreLikeWith :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [FacetDoc]
  68 moreLikeWith priors ft cId = do
  69
  70   docs_test  <- filter (\(FacetDoc _ _ _ _ f _) -> f == False)
  71               <$> runViewDocuments cId False Nothing Nothing Nothing
  72
  73   let results = map fst
  74        $ filter ((==) (Just $ not $ fav2bool ft) . snd)
  75        $ map (\f -> (f, detectDefaultWithPriors text priors f)) docs_test
  76
  77   pure results
  78
  79 ---------------------------------------------------------------------------
  80 fav2bool :: FavOrTrash -> Bool
  81 fav2bool ft = if (==) ft IsFav then True else False
  82
  83
  84 text :: FacetDoc -> Text
  85 text (FacetDoc _ _ _ h _ _)  = title <> "" <> Text.take 100 abstr
  86   where
  87     title = maybe "" identity (_hyperdataDocument_title    h)
  88     abstr = maybe "" identity (_hyperdataDocument_abstract h)
  89
  90 ---------------------------------------------------------------------------
  91
  92
  93 apply :: (FlowCmdM DevEnv GargError m) => FavOrTrash -> CorpusId -> [NodeId] -> m [Int]
  94 apply favTrash cId ns = case favTrash of
  95       IsFav   -> nodesToFavorite $ map (\n -> (cId, n, True)) ns
  96       IsTrash -> delDocs cId (Documents ns)
  97
  98
  99 moreLikeAndApply :: FlowCmdM DevEnv GargError m => FavOrTrash -> CorpusId -> m [Int]
 100 moreLikeAndApply ft cId = do
 101   priors <- getPriors ft cId
 102   moreLikeWithAndApply priors ft cId
 103
 104
 105 moreLikeWithAndApply :: FlowCmdM DevEnv GargError m => Events Bool -> FavOrTrash -> CorpusId -> m [Int]
 106 moreLikeWithAndApply priors ft cId = do
 107   ids <- map facetDoc_id <$> moreLikeWith priors ft cId
 108   apply ft cId ids
 109
 110