bin/gargantext-phylo/Main.hs

   1 {-|
   2 Module      : Main.hs
   3 Description : Gargantext starter binary with Adaptative Phylo
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Adaptative Phylo binaries
  11  -}
  12
  13 {-# LANGUAGE StandaloneDeriving #-}
  14 {-# LANGUAGE TypeOperators      #-}
  15 {-# LANGUAGE Strict             #-}
  16
  17 module Main where
  18
  19 -- import Debug.Trace (trace)
  20 import Control.Concurrent.Async (mapConcurrently)
  21 import Crypto.Hash.SHA256 (hash)
  22 import Data.Aeson
  23 import Data.Either (Either(..), fromRight)
  24 import Data.List  (concat, nub, isSuffixOf)
  25 import Data.List.Split
  26 import Data.Maybe (fromMaybe)
  27 import Data.String (String)
  28 import Data.Text  (Text, unwords, unpack, replace, pack)
  29 import GHC.IO (FilePath)
  30 import Gargantext.API.Ngrams.Prelude (toTermList)
  31 import Gargantext.API.Ngrams.Types
  32 import Gargantext.Core.Text.Context (TermList)
  33 import Gargantext.Core.Text.Corpus.Parsers (FileFormat(..), FileType(..), parseFile)
  34 import Gargantext.Core.Text.Corpus.Parsers.CSV (csv_title, csv_abstract, csv_publication_year, csv_publication_month, csv_publication_day, csv'_source, csv'_title, csv'_abstract, csv'_publication_year, csv'_publication_month, csv'_publication_day, csv'_weight)
  35 import Gargantext.Core.Text.List.Formats.CSV (csvMapTermList)
  36 import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, extractTermsWithList)
  37 import Gargantext.Core.Types.Main (ListType(..))
  38 import Gargantext.Core.Viz.Phylo
  39 import Gargantext.Core.Viz.Phylo.API.Tools
  40 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
  41 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
  42 import Gargantext.Core.Viz.Phylo.PhyloTools  (printIOMsg, printIOComment, setConfig)
  43 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
  44 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  45 import Gargantext.Prelude
  46 import System.Directory (listDirectory,doesFileExist)
  47 import System.Environment
  48 import qualified Data.ByteString.Char8                   as C8
  49 import qualified Data.Text                               as T
  50 import qualified Data.Vector                             as Vector
  51 import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv
  52
  53 data Backup = BackupPhyloWithoutLink | BackupPhylo deriving (Show)
  54
  55 ---------------
  56 -- | Tools | --
  57 ---------------
  58
  59 -- | To get all the files in a directory or just a file
  60 getFilesFromPath :: FilePath -> IO [FilePath]
  61 getFilesFromPath path = do
  62   if (isSuffixOf "/" path)
  63     then (listDirectory path)
  64     else return [path]
  65
  66 ----------------
  67 -- | Parser | --
  68 ----------------
  69
  70 -- | To filter the Ngrams of a document based on the termList
  71 termsInText :: Patterns -> Text -> [Text]
  72 termsInText pats txt = nub $ concat $ map (map unwords) $ extractTermsWithList pats txt
  73
  74
  75 -- | To transform a Wos file (or [file]) into a list of Docs
  76 wosToDocs :: Int -> Patterns -> TimeUnit -> FilePath -> IO [Document]
  77 wosToDocs limit patterns time path = do
  78       files <- getFilesFromPath path
  79       take limit
  80         <$> map (\d -> let title = fromJust $ _hd_title d
  81                            abstr = if (isJust $ _hd_abstract d)
  82                                    then fromJust $ _hd_abstract d
  83                                    else ""
  84                         in Document (toPhyloDate
  85                                       (fromIntegral $ fromJust $ _hd_publication_year d)
  86                                       (fromJust $ _hd_publication_month d)
  87                                       (fromJust $ _hd_publication_day d) time)
  88                                     (toPhyloDate'
  89                                       (fromIntegral $ fromJust $ _hd_publication_year d)
  90                                       (fromJust $ _hd_publication_month d)
  91                                       (fromJust $ _hd_publication_day d) time)
  92                                     (termsInText patterns $ title <> " " <> abstr) Nothing [])
  93         <$> concat
  94         <$> mapConcurrently (\file ->
  95               filter (\d -> (isJust $ _hd_publication_year d)
  96                          && (isJust $ _hd_title d))
  97                 <$> fromRight [] <$> parseFile WOS Plain (path <> file) ) files
  98
  99
 100 -- To transform a Csv file into a list of Document
 101 csvToDocs :: CorpusParser -> Patterns -> TimeUnit -> FilePath -> IO [Document]
 102 csvToDocs parser patterns time path =
 103   case parser of
 104     Wos  _     -> undefined
 105     Csv  limit -> Vector.toList
 106       <$> Vector.take limit
 107       <$> Vector.map (\row -> Document (toPhyloDate  (Csv.fromMIntOrDec Csv.defaultYear $ csv_publication_year row) (fromMaybe Csv.defaultMonth $ csv_publication_month row) (fromMaybe Csv.defaultDay $ csv_publication_day row) time)
 108                                        (toPhyloDate' (Csv.fromMIntOrDec Csv.defaultYear $ csv_publication_year row) (fromMaybe Csv.defaultMonth $ csv_publication_month row) (fromMaybe Csv.defaultDay $ csv_publication_day row) time)
 109                                        (termsInText patterns $ (csv_title row) <> " " <> (csv_abstract row))
 110                                        Nothing
 111                                        []
 112                      ) <$> snd <$> either (\err -> panic $ cs $ "CSV error" <> (show err)) identity <$> Csv.readCSVFile path
 113     Csv' limit -> Vector.toList
 114       <$> Vector.take limit
 115       <$> Vector.map (\row -> Document (toPhyloDate  (csv'_publication_year row) (csv'_publication_month row) (csv'_publication_day row) time)
 116                                        (toPhyloDate' (csv'_publication_year row) (csv'_publication_month row) (csv'_publication_day row) time)
 117                                        (termsInText patterns $ (csv'_title row) <> " " <> (csv'_abstract row))
 118                                        (Just $ csv'_weight row)
 119                                        (map (T.strip . pack) $ splitOn ";" (unpack $ (csv'_source row)))
 120                      ) <$> snd <$> Csv.readWeightedCsv path
 121
 122
 123 -- To parse a file into a list of Document
 124 fileToDocs' :: CorpusParser -> FilePath -> TimeUnit -> TermList -> IO [Document]
 125 fileToDocs' parser path time lst = do
 126   let patterns = buildPatterns lst
 127   case parser of
 128       Wos limit  -> wosToDocs limit  patterns time path
 129       Csv  _     -> csvToDocs parser patterns time path
 130       Csv' _     -> csvToDocs parser patterns time path
 131
 132
 133 ---------------
 134 -- | Label | --
 135 ---------------
 136
 137
 138 -- Config time parameters to label
 139 timeToLabel :: PhyloConfig -> [Char]
 140 timeToLabel config = case (timeUnit config) of
 141       Epoch p s f -> ("time_epochs" <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 142       Year  p s f -> ("time_years"  <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 143       Month p s f -> ("time_months" <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 144       Week  p s f -> ("time_weeks"  <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 145       Day   p s f -> ("time_days"   <> "_" <> (show p) <> "_" <> (show s) <> "_" <> (show f))
 146
 147
 148 seaToLabel :: PhyloConfig -> [Char]
 149 seaToLabel config = case (seaElevation config) of
 150       Constante start step   -> ("sea_cst_"  <> (show start) <> "_" <> (show step))
 151       Adaptative granularity -> ("sea_adapt" <> (show granularity))
 152       Evolving _ -> ("sea_evolv")
 153
 154
 155 sensToLabel :: PhyloConfig -> [Char]
 156 sensToLabel config = case (similarity config) of
 157       Hamming _ _ -> undefined
 158       WeightedLogJaccard s _ -> ("WeightedLogJaccard_"  <> show s)
 159       WeightedLogSim s _ -> ( "WeightedLogSim-sens_"  <> show s)
 160
 161
 162 cliqueToLabel :: PhyloConfig -> [Char]
 163 cliqueToLabel config = case (clique config) of
 164       Fis s s' -> "fis_" <> (show s) <> "_" <> (show s')
 165       MaxClique s t f ->  "clique_" <> (show s)<> "_"  <> (show f)<> "_"  <> (show t)
 166
 167
 168 syncToLabel :: PhyloConfig -> [Char]
 169 syncToLabel config = case (phyloSynchrony config) of
 170       ByProximityThreshold scl sync_sens scope _ -> ("scale_" <> (show scope) <> "_" <> (show sync_sens)  <> "_"  <> (show scl))
 171       ByProximityDistribution _ _ -> undefined
 172
 173 qualToConfig :: PhyloConfig -> [Char]
 174 qualToConfig config = case (phyloQuality config) of
 175       Quality g m -> "quality_" <> (show g) <> "_" <> (show m)
 176
 177
 178 -- To set up the export file's label from the configuration
 179 configToLabel :: PhyloConfig -> [Char]
 180 configToLabel config = outputPath config
 181                     <> (unpack $ phyloName config)
 182                     <> "-" <> (timeToLabel config)
 183                     <> "-scale_" <> (show (phyloScale config))
 184                     <> "-" <> (seaToLabel config)
 185                     <> "-" <> (sensToLabel config)
 186                     <> "-" <> (cliqueToLabel config)
 187                     <> "-level_" <> (show (_qua_granularity $ phyloQuality config))
 188                     <> "-" <> (syncToLabel config)
 189                     <> ".dot"
 190
 191
 192 -- To write a sha256 from a set of config's parameters
 193 configToSha :: Backup -> PhyloConfig -> [Char]
 194 configToSha stage config = unpack
 195                          $ replace "/" "-"
 196                          $ T.pack (show (hash $ C8.pack label))
 197   where
 198     label :: [Char]
 199     label = case stage of
 200       BackupPhyloWithoutLink -> (corpusPath    config)
 201                        <> (listPath      config)
 202                        <> (timeToLabel   config)
 203                        <> (cliqueToLabel config)
 204       BackupPhylo   -> (corpusPath    config)
 205                        <> (listPath      config)
 206                        <> (timeToLabel   config)
 207                        <> (cliqueToLabel config)
 208                        <> (sensToLabel   config)
 209                        <> (seaToLabel    config)
 210                        <> (syncToLabel   config)
 211                        <> (qualToConfig  config)
 212                        <> (show (phyloScale config))
 213
 214
 215 readListV4 :: [Char] -> IO NgramsList
 216 readListV4 path = do
 217   listJson <- (eitherDecode <$> readJson path) :: IO (Either String NgramsList)
 218   case listJson of
 219     Left err -> do
 220       putStrLn err
 221       undefined
 222     Right listV4 -> pure listV4
 223
 224
 225 fileToList  :: ListParser -> FilePath -> IO TermList
 226 fileToList parser path =
 227   case parser of
 228     V3 -> csvMapTermList path
 229     V4 -> fromJust
 230       <$> toTermList MapTerm NgramsTerms
 231       <$> readListV4 path
 232
 233
 234 --------------
 235 -- | Main | --
 236 --------------
 237
 238
 239 main :: IO ()
 240 main = do
 241
 242     printIOMsg "Starting the reconstruction"
 243
 244     printIOMsg "Read the configuration file"
 245     [args]   <- getArgs
 246     jsonArgs <- (eitherDecode <$> readJson args) :: IO (Either String PhyloConfig)
 247
 248     case jsonArgs of
 249         Left err     -> putStrLn err
 250         Right config -> do
 251
 252             printIOMsg "Parse the corpus"
 253             mapList <-  fileToList (listParser config) (listPath config)
 254             corpus  <- fileToDocs' (corpusParser config) (corpusPath config) (timeUnit config) mapList
 255             printIOComment (show (length corpus) <> " parsed docs from the corpus")
 256
 257             printIOComment (show (length $ nub $ concat $ map text corpus) <> " Size ngs_coterms")
 258
 259             printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")
 260
 261             printIOMsg "Reconstruct the phylo"
 262
 263             -- check the existing backup files
 264
 265             let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
 266             let backupPhylo = (outputPath config) <> "backupPhylo_"   <> (configToSha BackupPhylo config) <> ".json"
 267
 268             phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
 269             phyloExists   <- doesFileExist backupPhylo
 270
 271             -- reconstruct the phylo
 272
 273             phylo <- if phyloExists
 274                         then do
 275                           printIOMsg "Reconstruct the phylo from an existing file"
 276                           readPhylo backupPhylo
 277                         else do
 278                           if phyloWithoutLinkExists
 279                             then do
 280                               printIOMsg "Reconstruct the phylo from an existing file without links"
 281                               phyloWithoutLink <- readPhylo backupPhyloWithoutLink
 282                               writePhylo backupPhyloWithoutLink phyloWithoutLink
 283                               pure $ toPhylo (setConfig config phyloWithoutLink)
 284                             else do
 285                               printIOMsg "Reconstruct the phylo from scratch"
 286                               phyloWithoutLink <- pure $ toPhyloWithoutLink corpus config
 287                               writePhylo backupPhyloWithoutLink phyloWithoutLink
 288                               pure $ toPhylo (setConfig config phyloWithoutLink)
 289
 290             writePhylo backupPhylo phylo
 291
 292             printIOMsg "End of reconstruction, start the export"
 293
 294             let dot = toPhyloExport (setConfig config phylo)
 295
 296             let output = configToLabel config
 297
 298             dotToFile output dot