From 14fa13938cea7df198fe863dbbd87242637e93ec Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli <alfredo@well-typed.com> Date: Tue, 19 Mar 2024 09:29:28 +0100 Subject: [PATCH] Add ToExpr to Phylo --- gargantext.cabal | 1 + src/Gargantext/Core/Viz/Phylo.hs | 55 ++++++++++++++++---------------- test/Test/Offline/Phylo.hs | 42 ++++++++++++------------ 3 files changed, 51 insertions(+), 47 deletions(-) diff --git a/gargantext.cabal b/gargantext.cabal index eae10d10..28a81c9e 100644 --- a/gargantext.cabal +++ b/gargantext.cabal @@ -616,6 +616,7 @@ library , timezone-series ^>= 0.1.13 , transformers ^>= 0.5.6.2 , transformers-base ^>= 0.4.6 + , tree-diff , tomland >= 1.3.3.2 , tuple ^>= 0.3.0.2 , unordered-containers ^>= 0.2.16.0 diff --git a/src/Gargantext/Core/Viz/Phylo.hs b/src/Gargantext/Core/Viz/Phylo.hs index e0ed1bae..0a54102f 100644 --- a/src/Gargantext/Core/Viz/Phylo.hs +++ b/src/Gargantext/Core/Viz/Phylo.hs @@ -33,6 +33,7 @@ import Data.Aeson.TH (deriveJSON) import Data.Swagger import Data.Text (pack) import Data.Text.Lazy qualified as TextLazy +import Data.TreeDiff import Data.Vector (Vector) import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefixSwagger) @@ -48,13 +49,13 @@ data CorpusParser = Wos {_wos_limit :: Int} | Csv {_csv_limit :: Int} | Csv' {_csv'_limit :: Int} - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq, ToExpr) instance ToSchema CorpusParser where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_") -data ListParser = V3 | V4 deriving (Show,Generic,Eq) +data ListParser = V3 | V4 deriving (Show,Generic,Eq,ToExpr) instance ToSchema ListParser @@ -66,7 +67,7 @@ data SeaElevation = { _adap_steps :: Double } | Evolving { _evol_neighborhood :: Bool } - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema SeaElevation @@ -81,17 +82,17 @@ data PhyloSimilarity = { _hmg_sensibility :: Double , _hmg_minSharedNgrams :: Int} - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema PhyloSimilarity where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") data SynchronyScope = SingleBranch | SiblingBranches | AllBranches - deriving (Show,Generic,Eq, ToSchema) + deriving (Show,Generic,Eq, ToSchema, ToExpr) data SynchronyStrategy = MergeRegularGroups | MergeAllGroups - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema SynchronyStrategy where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") @@ -106,7 +107,7 @@ data Synchrony = | ByProximityDistribution { _bpd_sensibility :: Double , _bpd_strategy :: SynchronyStrategy } - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema Synchrony where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_") @@ -134,13 +135,13 @@ data TimeUnit = { _day_period :: Int , _day_step :: Int , _day_matchingFrame :: Int } - deriving (Show,Generic,Eq,NFData) + deriving (Show,Generic,Eq,NFData,ToExpr) instance ToSchema TimeUnit where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") -data MaxCliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq) +data MaxCliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq,ToExpr) instance ToSchema MaxCliqueFilter where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") @@ -155,7 +156,7 @@ data Cluster = { _mcl_size :: Int , _mcl_threshold :: Double , _mcl_filter :: MaxCliqueFilter } - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema Cluster where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") @@ -164,7 +165,7 @@ instance ToSchema Cluster where data Quality = Quality { _qua_granularity :: Double , _qua_minBranch :: Int } - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema Quality where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_qua_") @@ -189,7 +190,7 @@ data PhyloConfig = , exportLabel :: [PhyloLabel] , exportSort :: Sort , exportFilter :: [Filter] - } deriving (Show,Generic,Eq) + } deriving (Show,Generic,Eq,ToExpr) -------------------------------- -- | SubConfig API & 1Click | -- @@ -306,7 +307,7 @@ instance ToJSON Quality data Software = Software { _software_name :: Text , _software_version :: Text - } deriving (Generic, Show, Eq) + } deriving (Generic, Show, Eq, ToExpr) instance ToSchema Software where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_software_") @@ -324,7 +325,7 @@ data PhyloParam = PhyloParam { _phyloParam_version :: Text , _phyloParam_software :: Software , _phyloParam_config :: PhyloConfig - } deriving (Generic, Show, Eq) + } deriving (Generic, Show, Eq, ToExpr) instance ToSchema PhyloParam where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phyloParam_") @@ -373,7 +374,7 @@ data Document = Document data PhyloFoundations = PhyloFoundations { _foundations_roots :: (Vector Ngrams) , _foundations_rootsInGroups :: Map Int [PhyloGroupId] -- map of roots associated to groups - } deriving (Generic, Show, Eq) + } deriving (Generic, Show, Eq, ToExpr) data PhyloCounts = PhyloCounts { coocByDate :: !(Map Date Cooc) @@ -382,10 +383,10 @@ data PhyloCounts = PhyloCounts , rootsCount :: !(Map Int Double) , rootsFreq :: !(Map Int Double) , lastRootsFreq :: !(Map Int Double) - } deriving (Generic, Show, Eq) + } deriving (Generic, Show, Eq, ToExpr) data PhyloSources = PhyloSources - { _sources :: !(Vector Text) } deriving (Generic, Show, Eq) + { _sources :: !(Vector Text) } deriving (Generic, Show, Eq, ToExpr) instance ToSchema PhyloFoundations where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_foundations_") @@ -432,7 +433,7 @@ data Phylo = , _phylo_quality :: Double , _phylo_level :: Double } - deriving (Generic, Show, Eq) + deriving (Generic, Show, Eq, ToExpr) instance ToSchema Phylo where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") @@ -449,7 +450,7 @@ data PhyloPeriod = PhyloPeriod { _phylo_periodPeriod :: Period , _phylo_periodPeriodStr :: PeriodStr , _phylo_periodScales :: Map PhyloScaleId PhyloScale - } deriving (Generic, Show, Eq) + } deriving (Generic, Show, Eq, ToExpr) instance ToSchema PhyloPeriod where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") @@ -471,7 +472,7 @@ data PhyloScale = , _phylo_scaleScale :: Scale , _phylo_scaleGroups :: Map PhyloGroupId PhyloGroup } - deriving (Generic, Show, Eq) + deriving (Generic, Show, Eq, ToExpr) instance ToSchema PhyloScale where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") @@ -506,7 +507,7 @@ data PhyloGroup = , _phylo_groupPeriodMemoryParents :: [Pointer'] , _phylo_groupPeriodMemoryChilds :: [Pointer'] } - deriving (Generic, Show, Eq, NFData, Ord) + deriving (Generic, Show, Eq, NFData, Ord, ToExpr) instance ToSchema PhyloGroup where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_") @@ -547,19 +548,19 @@ data Clustering = Clustering type DotId = TextLazy.Text -data EdgeType = GroupToGroup | GroupToGroupMemory | BranchToGroup | BranchToBranch | GroupToAncestor | PeriodToPeriod deriving (Show,Generic,Eq) +data EdgeType = GroupToGroup | GroupToGroupMemory | BranchToGroup | BranchToBranch | GroupToAncestor | PeriodToPeriod deriving (Show,Generic,Eq,ToExpr) -data Filter = ByBranchSize { _branch_size :: Double } deriving (Show,Generic,Eq) +data Filter = ByBranchSize { _branch_size :: Double } deriving (Show,Generic,Eq,ToExpr) instance ToSchema Filter where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") -data Order = Asc | Desc deriving (Show,Generic,Eq, ToSchema) +data Order = Asc | Desc deriving (Show,Generic,Eq, ToSchema, ToExpr) -data Sort = ByBirthDate { _sort_order :: Order } | ByHierarchy {_sort_order :: Order } deriving (Show,Generic,Eq) +data Sort = ByBirthDate { _sort_order :: Order } | ByHierarchy {_sort_order :: Order } deriving (Show,Generic,Eq,ToExpr) instance ToSchema Sort where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_sort_") -data Tagger = MostInclusive | MostEmergentInclusive | MostEmergentTfIdf deriving (Show,Generic,Eq) +data Tagger = MostInclusive | MostEmergentInclusive | MostEmergentTfIdf deriving (Show,Generic,Eq,ToExpr) instance ToSchema Tagger where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "") @@ -570,7 +571,7 @@ data PhyloLabel = | GroupLabel { _group_labelTagger :: Tagger , _group_labelSize :: Int } - deriving (Show,Generic,Eq) + deriving (Show,Generic,Eq,ToExpr) instance ToSchema PhyloLabel where declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_") diff --git a/test/Test/Offline/Phylo.hs b/test/Test/Offline/Phylo.hs index 49fbc935..c3a761c0 100644 --- a/test/Test/Offline/Phylo.hs +++ b/test/Test/Offline/Phylo.hs @@ -5,23 +5,25 @@ module Test.Offline.Phylo (tests) where +import Common import Data.Aeson import Data.GraphViz.Attributes.Complete qualified as Graphviz import Data.Text.Lazy as TL +import Data.TreeDiff import Data.Vector qualified as V import Gargantext.Core.Viz.Phylo import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo, writePhylo) import Gargantext.Core.Viz.Phylo.PhyloExport import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink) import Gargantext.Core.Viz.Phylo.PhyloTools +import Paths_gargantext import Prelude +import Test.QuickCheck +import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Common -import Paths_gargantext - phyloConfig :: PhyloConfig phyloConfig = PhyloConfig { corpusPath = "corpus.csv" @@ -53,39 +55,39 @@ tests = testGroup "Phylo" [ , testCase "ngramsToLabel is rendered correctly in CustomAttribute" test_ngramsToLabel_02 ] , testGroup "toPhyloWithoutLink" [ - testCase "returns expected data" testSmallPhyloWithoutLinkExpectedOutput + testProperty "returns expected data" testSmallPhyloWithoutLinkExpectedOutput ] , testGroup "toPhylo" [ - testCase "returns expected data" testSmallPhyloExpectedOutput + testProperty "returns expected data" testSmallPhyloExpectedOutput ] , testGroup "relatedComponents" [ testCase "finds simple connection" testRelComp_Connected ] ] -testSmallPhyloWithoutLinkExpectedOutput :: Assertion -testSmallPhyloWithoutLinkExpectedOutput = do - bpaConfig <- getDataFileName "bench-data/phylo/bpa-config.json" - corpusPath' <- getDataFileName "test-data/phylo/small_phylo_docslist.csv" - listPath' <- getDataFileName "test-data/phylo/small_phylo_ngramslist.csv" +testSmallPhyloWithoutLinkExpectedOutput :: Property +testSmallPhyloWithoutLinkExpectedOutput = monadicIO $ do + bpaConfig <- run $ getDataFileName "bench-data/phylo/bpa-config.json" + corpusPath' <- run $ getDataFileName "test-data/phylo/small_phylo_docslist.csv" + listPath' <- run $ getDataFileName "test-data/phylo/small_phylo_ngramslist.csv" (Right config) <- fmap (\pcfg -> pcfg { corpusPath = corpusPath' , listPath = listPath' - }) <$> (eitherDecodeFileStrict' bpaConfig) - mapList <- fileToList (listParser config) (listPath config) - corpus <- fileToDocsDefault (corpusParser config) + }) <$> (run $ eitherDecodeFileStrict' bpaConfig) + mapList <- run $ fileToList (listParser config) (listPath config) + corpus <- run $ fileToDocsDefault (corpusParser config) (corpusPath config) [Year 3 1 5,Month 3 1 5,Week 4 2 5] mapList actual <- pure $ toPhyloWithoutLink corpus config - expected <- readPhylo =<< getDataFileName "test-data/phylo/small-phylo.golden.json" - expected @?= actual + expected <- run $ readPhylo =<< getDataFileName "test-data/phylo/small-phylo.golden.json" + pure $ counterexample (show $ ansiWlEditExpr $ ediff' expected actual) (expected === actual) -testSmallPhyloExpectedOutput :: Assertion -testSmallPhyloExpectedOutput = do - issue290PhyloSmall <- setConfig phyloConfig <$> (readPhylo =<< getDataFileName "bench-data/phylo/issue-290-small.json") - expected <- readPhylo =<< getDataFileName "test-data/phylo/issue-290-small.golden.json" +testSmallPhyloExpectedOutput :: Property +testSmallPhyloExpectedOutput = monadicIO $ do + issue290PhyloSmall <- run $ setConfig phyloConfig <$> (readPhylo =<< getDataFileName "bench-data/phylo/issue-290-small.json") + expected <- run $ readPhylo =<< getDataFileName "test-data/phylo/issue-290-small.golden.json" let actual = toPhylo issue290PhyloSmall - expected @?= actual + pure $ counterexample (show $ ansiWlEditExpr $ ediff' expected actual) (expected === actual) test_ngramsToLabel_01 :: Assertion test_ngramsToLabel_01 = -- 2.21.0