-}
-{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
module Gargantext.Text.Terms
where
import Control.Lens
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Text (Text)
import Data.Traversable
-
-import Gargantext.Prelude
+import GHC.Base (String)
+import GHC.Generics (Generic)
import Gargantext.Core
import Gargantext.Core.Types
-import Gargantext.Text.Terms.Multi (multiterms)
+import Gargantext.Core.Flow.Types
+import Gargantext.Prelude
+import Gargantext.Text (sentences, HasText(..))
+import Gargantext.Text.Terms.Eleve (mainEleveWith, Tries, Token, buildTries, toToken)
+import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..))
import Gargantext.Text.Terms.Mono (monoTerms)
-
+import Gargantext.Database.Prelude (Cmd)
+import Gargantext.Text.Terms.Mono.Stem (stem)
+import Gargantext.Text.Terms.Mono.Token.En (tokenize)
+import Gargantext.Text.Terms.Multi (multiterms)
+import qualified Data.List as List
+import qualified Data.Set as Set
+import qualified Data.Text as Text
data TermType lang
- = Mono { _tt_lang :: lang }
- | Multi { _tt_lang :: lang }
- | MonoMulti { _tt_lang :: lang }
+ = Mono { _tt_lang :: !lang }
+ | Multi { _tt_lang :: !lang }
+ | MonoMulti { _tt_lang :: !lang }
+ | Unsupervised { _tt_lang :: !lang
+ , _tt_windowSize :: !Int
+ , _tt_ngramsSize :: !Int
+ , _tt_model :: !(Maybe (Tries Token ()))
+ }
+ deriving Generic
makeLenses ''TermType
-
--group :: [Text] -> [Text]
--group = undefined
-- | Sugar to extract terms from text (hiddeng mapM from end user).
--extractTerms :: Traversable t => TermType Lang -> t Text -> IO (t [Terms])
extractTerms :: TermType Lang -> [Text] -> IO [[Terms]]
-extractTerms termTypeLang = mapM (terms termTypeLang)
+
+extractTerms (Unsupervised l n s m) xs = mapM (terms (Unsupervised l n s (Just m'))) xs
+ where
+ m' = case m of
+ Just m''-> m''
+ Nothing -> newTries n (Text.intercalate " " xs)
+
+extractTerms termTypeLang xs = mapM (terms termTypeLang) xs
+
+
------------------------------------------------------------------------
+withLang :: HasText a
+ => TermType Lang
+ -> [DocumentWithId a]
+ -> TermType Lang
+withLang (Unsupervised l n s m) ns = Unsupervised l n s m'
+ where
+ m' = case m of
+ Nothing -> -- trace ("buildTries here" :: String)
+ Just $ buildTries n ( fmap toToken
+ $ uniText
+ $ Text.intercalate " . "
+ $ List.concat
+ $ map hasText ns
+ )
+ just_m -> just_m
+withLang l _ = l
+------------------------------------------------------------------------
+
+
+class ExtractNgramsT h
+ where
+ extractNgramsT :: HasText h
+ => TermType Lang
+ -> h
+ -> Cmd err (Map Ngrams (Map NgramsType Int))
+
+filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
+ -> Map Ngrams (Map NgramsType Int)
+filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
+ where
+ filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
+ True -> (ng,y)
+ False -> (Ngrams (Text.take s' t) n , y)
+
+
+-- =======================================================
+
-- | Terms from Text
-- Mono : mono terms
-- Multi : multi terms
terms (Mono lang) txt = pure $ monoTerms lang txt
terms (Multi lang) txt = multiterms lang txt
terms (MonoMulti lang) txt = terms (Multi lang) txt
+terms (Unsupervised lang n s m) txt = termsUnsupervised (Unsupervised lang n s (Just m')) txt
+ where
+ m' = maybe (newTries n txt) identity m
-- terms (WithList list) txt = pure . concat $ extractTermsWithList list txt
------------------------------------------------------------------------
+text2term :: Lang -> [Text] -> Terms
+text2term _ [] = Terms [] Set.empty
+text2term lang txt = Terms txt (Set.fromList $ map (stem lang) txt)
+
+isPunctuation :: Text -> Bool
+isPunctuation x = List.elem x $ (Text.pack . pure)
+ <$> ("!?(),;." :: String)
+
+-- | Unsupervised ngrams extraction
+-- language agnostic extraction
+-- TODO: remove IO
+-- TODO: newtype BlockText
+
+type WindowSize = Int
+type MinNgramSize = Int
+
+termsUnsupervised :: TermType Lang -> Text -> IO [Terms]
+termsUnsupervised (Unsupervised l n s m) =
+ pure
+ . map (text2term l)
+ . List.nub
+ . (List.filter (\l' -> List.length l' >= s))
+ . List.concat
+ . mainEleveWith (maybe (panic "no model") identity m) n
+ . uniText
+termsUnsupervised _ = undefined
+
+newTries :: Int -> Text -> Tries Token ()
+newTries n t = buildTries n (fmap toToken $ uniText t)
+
+-- | TODO removing long terms > 24
+uniText :: Text -> [[Text]]
+uniText = map (List.filter (not . isPunctuation))
+ . map tokenize
+ . sentences -- TODO get sentences according to lang
+ . Text.toLower
+