[WORKFLOW] Unsupervised ngrams extraction implemented.

src/Gargantext/Database/Flow.hs

@@ -20,10 +20,12 @@ Portability : POSIX
 
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE InstanceSigs      #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
 
 module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
     where
@@ -58,14 +60,14 @@ import Gargantext.Database.Utils (Cmd, CmdM)
 import Gargantext.Ext.IMT (toSchoolName)
 import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 import Gargantext.Prelude
+import Gargantext.Text.Terms.Eleve (buildTries, toToken)
 import Gargantext.Text.List (buildNgramsLists,StopSize(..))
 import Gargantext.Text.Parsers (parseFile, FileFormat)
-import Gargantext.Text.Terms (TermType(..), tt_lang)
-import Gargantext.Text.Terms (extractTerms)
+import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText)
 import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
 import Servant (ServantErr)
 import System.FilePath (FilePath)
---import qualified Data.List as List
+import qualified Data.List as List
 import qualified Data.Map  as Map
 import qualified Data.Text as Text
 import qualified Gargantext.Database.Node.Document.Add  as Doc  (add)
@@ -82,6 +84,7 @@ type FlowCorpus a = ( AddUniqId a
                     , UniqId a
                     , InsertDb a
                     , ExtractNgramsT a
+                    , HasText a
                     )
 
 ------------------------------------------------------------------------
@@ -186,8 +189,17 @@ insertMasterDocs c lang hs  =  do
   ids <- insertDb masterUserId masterCorpusId hs'
   let documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' hs')
   
+  let 
+    fixLang (Unsupervised l n m) = Unsupervised l n m'
+      where
+        m' = case m of
+          Nothing -> Just $ buildTries n (fmap toToken $ uniText $ Text.intercalate " " $ List.concat $ map hasText documentsWithId)
+          m'' -> m''
+    fixLang l = l
+
+    lang' = fixLang lang
   -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
-  maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang) documentsWithId
+  maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang') documentsWithId
   terms2id <- insertNgrams $ Map.keys maps
   let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
   
@@ -265,6 +277,10 @@ data DocumentWithId a = DocumentWithId
   , documentData :: !a
   } deriving (Show)
 
+instance HasText a => HasText (DocumentWithId a)
+  where
+    hasText (DocumentWithId _ a) = hasText a
+
 mergeData :: Map HashId ReturnId
           -> Map HashId a
           -> [DocumentWithId a]
@@ -280,12 +296,18 @@ data DocumentIdWithNgrams a = DocumentIdWithNgrams
   , document_ngrams :: !(Map Ngrams (Map NgramsType Int))
   } deriving (Show)
 
--- TODO extractNgrams according to Type of Data
 
 class ExtractNgramsT h
   where
-    extractNgramsT :: TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
+    extractNgramsT :: HasText h => TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
 
+class HasText h
+  where
+    hasText :: h -> [Text]
+
+instance HasText HyperdataContact
+  where
+    hasText = undefined
 
 instance ExtractNgramsT HyperdataContact
   where
@@ -300,45 +322,42 @@ instance ExtractNgramsT HyperdataContact
         
           pure $ Map.fromList $ [(a', Map.singleton Authors     1) | a' <- authors    ]
 
-
-
-instance ExtractNgramsT HyperdataDocument
+instance HasText HyperdataDocument
   where
-    extractNgramsT = extractNgramsT'
+    hasText h = catMaybes [ _hyperdataDocument_title    h
+                          , _hyperdataDocument_abstract h
+                          ]
 
-extractNgramsT' :: TermType Lang -> HyperdataDocument
-               -> Cmd err (Map Ngrams (Map NgramsType Int))
-extractNgramsT' lang hd = filterNgramsT 255 <$> extractNgramsT'' lang hd
+instance ExtractNgramsT HyperdataDocument
   where
-    extractNgramsT'' :: TermType Lang -> HyperdataDocument
-                   -> Cmd err (Map Ngrams (Map NgramsType Int))
-    extractNgramsT'' lang' doc = do
-      let source    = text2ngrams
-                    $ maybe "Nothing" identity
-                    $ _hyperdataDocument_source doc
-
-          institutes = map text2ngrams
-                     $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
-                     $ _hyperdataDocument_institutes doc
-
-          authors    = map text2ngrams
-                     $ maybe ["Nothing"] (splitOn ", ")
-                     $ _hyperdataDocument_authors doc
-
-          leText = catMaybes [ _hyperdataDocument_title    doc
-                             , _hyperdataDocument_abstract doc
-                             ]
-
-      terms' <- map text2ngrams
-             <$> map (intercalate " " . _terms_label)
-             <$> concat
-             <$> liftIO (extractTerms lang' leText)
-
-      pure $ Map.fromList $  [(source, Map.singleton Sources 1)]
-                         <> [(i', Map.singleton Institutes  1) | i' <- institutes ]
-                         <> [(a', Map.singleton Authors     1) | a' <- authors    ]
-                         <> [(t', Map.singleton NgramsTerms 1) | t' <- terms'     ]
-
+    extractNgramsT :: TermType Lang -> HyperdataDocument -> Cmd err (Map Ngrams (Map NgramsType Int))
+    extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
+      where
+        extractNgramsT' :: TermType Lang -> HyperdataDocument
+                       -> Cmd err (Map Ngrams (Map NgramsType Int))
+        extractNgramsT' lang' doc = do
+          let source    = text2ngrams
+                        $ maybe "Nothing" identity
+                        $ _hyperdataDocument_source doc
+    
+              institutes = map text2ngrams
+                         $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
+                         $ _hyperdataDocument_institutes doc
+    
+              authors    = map text2ngrams
+                         $ maybe ["Nothing"] (splitOn ", ")
+                         $ _hyperdataDocument_authors doc
+    
+          terms' <- map text2ngrams
+                 <$> map (intercalate " " . _terms_label)
+                 <$> concat
+                 <$> liftIO (extractTerms lang' $ hasText doc)
+    
+          pure $ Map.fromList $  [(source, Map.singleton Sources 1)]
+                             <> [(i', Map.singleton Institutes  1) | i' <- institutes ]
+                             <> [(a', Map.singleton Authors     1) | a' <- authors    ]
+                             <> [(t', Map.singleton NgramsTerms 1) | t' <- terms'     ]
+    
 
 filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
                      -> Map Ngrams (Map NgramsType Int)
@@ -357,8 +376,8 @@ documentIdWithNgrams :: HasNodeError err
 documentIdWithNgrams f = mapM toDocumentIdWithNgrams
   where
     toDocumentIdWithNgrams d = do
-      e <- f $ documentData d
-      pure $ DocumentIdWithNgrams d e
+      e <- f $ documentData         d
+      pure   $ DocumentIdWithNgrams d e
 
 
 -- FLOW LIST

src/Gargantext/Text/Terms.hs

@@ -72,10 +72,17 @@ makeLenses ''TermType
 -- | 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 (Unsupervised l n m) xs = mapM (terms (Unsupervised l n m')) xs
+
+extractTerms (Unsupervised l n m) xs = mapM (terms (Unsupervised l n (Just m'))) xs
   where
-    m' = maybe (Just $ newTries n (Text.intercalate " " xs)) Just m
+    m' = case m of
+      Just m''-> m''
+      Nothing -> newTries n (Text.intercalate " " xs)
+
 extractTerms termTypeLang xs = mapM (terms termTypeLang) xs
+
+
+
 ------------------------------------------------------------------------
 -- | Terms from Text
 -- Mono : mono terms