-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Viz.Graph
where
-------------------------------------------------------------------------
-import GHC.IO (FilePath)
-import GHC.Generics (Generic)
+import Control.Lens (makeLenses)
import Data.Aeson.TH (deriveJSON)
-import qualified Data.Aeson as DA
-
import Data.ByteString.Lazy as DBL (readFile, writeFile)
-
+import Data.Swagger
import Data.Text (Text, pack)
-import qualified Text.Read as T
-import qualified Data.Text as T
-
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-
-import Data.Swagger (ToSchema)
-
+import GHC.Generics (Generic)
+import GHC.IO (FilePath)
+import Gargantext.Core.Types (ListId)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Database.Admin.Types.Node (NodeId, Hyperdata)
import Gargantext.Prelude
-import Gargantext.Core.Types (Label)
-import Gargantext.Core.Utils.Prefix (unPrefix)
-
-import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
-
-import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Test.QuickCheck (elements)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
+import Gargantext.Database.Prelude (fromField')
+import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Data.Aeson as DA
+import qualified Data.Text as T
+import qualified Text.Read as T
-------------------------------------------------------------------------
data TypeNode = Terms | Unknown
deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''TypeNode)
+instance ToSchema TypeNode
data Attributes = Attributes { clust_default :: Int }
deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''Attributes)
+instance ToSchema Attributes
data Node = Node { node_size :: Int
- , node_type :: TypeNode
- , node_id :: Text
+ , node_type :: TypeNode -- TODO NgramsType | Person
+ , node_id :: Text -- TODO NgramId
, node_label :: Text
+ , node_x_coord :: Double
+ , node_y_coord :: Double
, node_attributes :: Attributes
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "node_") ''Node)
+instance ToSchema Node where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
+
data Edge = Edge { edge_source :: Text
, edge_target :: Text
, edge_weight :: Double
+ , edge_confluence :: Double
, edge_id :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "edge_") ''Edge)
+instance ToSchema Edge where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
+
+---------------------------------------------------------------
+data LegendField = LegendField { _lf_id :: Int
+ , _lf_color :: Text
+ , _lf_label :: Text
+ } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_lf_") ''LegendField)
+
+instance ToSchema LegendField where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
+
+makeLenses ''LegendField
+---------------------------------------------------------------
+type Version = Int
+data ListForGraph = ListForGraph { _lfg_listId :: ListId
+ , _lfg_version :: Version
+ } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
+
+instance ToSchema ListForGraph where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
+
+makeLenses ''ListForGraph
+
+--
+data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the graph
+ , _gm_corpusId :: [NodeId] -- we can map with different corpus
+ , _gm_legend :: [LegendField] -- legend of the Graph
+ , _gm_list :: ListForGraph
+ -- , _gm_version :: Int
+ }
+ deriving (Show, Generic)
+$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
+instance ToSchema GraphMetadata where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
+makeLenses ''GraphMetadata
+
-data Graph = Graph { graph_nodes :: [Node]
- , graph_edges :: [Edge]
+data Graph = Graph { _graph_nodes :: [Node]
+ , _graph_edges :: [Edge]
+ , _graph_metadata :: Maybe GraphMetadata
}
deriving (Show, Generic)
-$(deriveJSON (unPrefix "graph_") ''Graph)
+$(deriveJSON (unPrefix "_graph_") ''Graph)
+makeLenses ''Graph
--- | Intances for Swagger documentation
-instance ToSchema Node
-instance ToSchema TypeNode
-instance ToSchema Attributes
-instance ToSchema Edge
-instance ToSchema Graph
+instance ToSchema Graph where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
-- | Intances for the mack
instance Arbitrary Graph where
- arbitrary = elements $ [Graph {graph_nodes = [Node {node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_size = 2, node_type = Terms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}}], graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_id = pack "16"}]}]
+ arbitrary = elements $ [defaultGraph]
+
+defaultGraph :: Graph
+defaultGraph = Graph {_graph_nodes = [Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = Terms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = Terms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = Terms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = Terms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = Terms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}}], _graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "16"}], _graph_metadata = Nothing}
-----------------------------------------------------------
--- Old Gargantext Version
+-- V3 Gargantext Version
-data AttributesOld = AttributesOld { cl :: Int }
+data AttributesV3 = AttributesV3 { cl :: Int }
deriving (Show, Generic)
-$(deriveJSON (unPrefix "") ''AttributesOld)
+$(deriveJSON (unPrefix "") ''AttributesV3)
-data NodeOld = NodeOld { no_id :: Int
- , no_at :: AttributesOld
- , no_s :: Int
- , no_lb :: Text
- }
+data NodeV3 = NodeV3 { no_id :: Int
+ , no_at :: AttributesV3
+ , no_s :: Int
+ , no_lb :: Text
+ }
deriving (Show, Generic)
-$(deriveJSON (unPrefix "no_") ''NodeOld)
+$(deriveJSON (unPrefix "no_") ''NodeV3)
-data EdgeOld = EdgeOld { eo_s :: Int
- , eo_t :: Int
- , eo_w :: Text
- }
+data EdgeV3 = EdgeV3 { eo_s :: Int
+ , eo_t :: Int
+ , eo_w :: Text
+ }
deriving (Show, Generic)
-$(deriveJSON (unPrefix "eo_") ''EdgeOld)
+$(deriveJSON (unPrefix "eo_") ''EdgeV3)
-data GraphOld = GraphOld {
- go_links :: [EdgeOld]
- , go_nodes :: [NodeOld]
- }
+data GraphV3 = GraphV3 { go_links :: [EdgeV3]
+ , go_nodes :: [NodeV3]
+ }
deriving (Show, Generic)
-$(deriveJSON (unPrefix "go_") ''GraphOld)
-
-----------------------------------------------------------
--- | From data to Graph
--- FIXME: distance should not be a map since we just "toList" it (same as cLouvain)
-data2graph :: [(Label, Int)] -> Map (Int, Int) Int
- -> Map (Int, Int) Double
- -> [LouvainNode]
- -> Graph
-data2graph labels coocs distance partitions = Graph nodes edges
- where
- community_id_by_node_id = M.fromList [ (n, c) | LouvainNode n c <- partitions ]
- nodes = [ Node { node_size = maybe 0 identity (M.lookup (n,n) coocs)
- , node_type = Terms -- or Unknown
- , node_id = cs (show n)
- , node_label = T.unwords l
- , node_attributes =
- Attributes { clust_default = maybe 0 identity
- (M.lookup n community_id_by_node_id) } }
- | (l, n) <- labels ]
- edges = [ Edge { edge_source = cs (show s)
- , edge_target = cs (show t)
- , edge_weight = w
- , edge_id = cs (show i) }
- | (i, ((s,t), w)) <- zip ([0..]::[Integer]) (M.toList distance) ]
+$(deriveJSON (unPrefix "go_") ''GraphV3)
+
-----------------------------------------------------------
+
+data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
+ } deriving (Show, Generic)
+$(deriveJSON (unPrefix "") ''HyperdataGraph)
+
+instance Hyperdata HyperdataGraph
+makeLenses ''HyperdataGraph
+
+instance FromField HyperdataGraph
+ where
+ fromField = fromField'
+
+instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
+ where
+ queryRunnerColumnDefault = fieldQueryRunnerColumn
+
+
-----------------------------------------------------------
-graphOld2graph :: GraphOld -> Graph
-graphOld2graph (GraphOld links nodes) = Graph (map nodeOld2node nodes) (zipWith linkOld2edge [1..] links)
+graphV3ToGraph :: GraphV3 -> Graph
+graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
where
- nodeOld2node :: NodeOld -> Node
- nodeOld2node (NodeOld no_id' (AttributesOld cl') no_s' no_lb')
- = Node no_s' Terms (cs $ show no_id') no_lb' (Attributes cl')
-
- linkOld2edge :: Int -> EdgeOld -> Edge
- linkOld2edge n (EdgeOld eo_s' eo_t' eo_w') = Edge (cs $ show eo_s') (cs $ show eo_t') ((T.read $ T.unpack eo_w') :: Double) (cs $ show n)
+ nodeV32node :: NodeV3 -> Node
+ nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
+ = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
+ linkV32edge :: Int -> EdgeV3 -> Edge
+ linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s') (cs $ show eo_t') ((T.read $ T.unpack eo_w') :: Double) 0.5 (cs $ show n)
-graphOld2graphWithFiles :: FilePath -> FilePath -> IO ()
-graphOld2graphWithFiles g1 g2 = do
- -- GraphOld <- IO Fichier
+
+graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
+graphV3ToGraphWithFiles g1 g2 = do
+ -- GraphV3 <- IO Fichier
graph <- DBL.readFile g1
- let newGraph = case DA.decode graph :: Maybe GraphOld of
+ let newGraph = case DA.decode graph :: Maybe GraphV3 of
Nothing -> panic (T.pack "no graph")
Just new -> new
- DBL.writeFile g2 (DA.encode $ graphOld2graph newGraph)
-
+ DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
+readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
+readGraphFromJson fp = do
+ graph <- liftBase $ DBL.readFile fp
+ pure $ DA.decode graph