Add ToExpr to Phylo

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

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 "_")

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 =