src/Gargantext/Viz/Graph.hs

   1 {-|
   2 Module      : Gargantext.Viz.Graph
   3 Description : Graph utils
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13
  14 {-# LANGUAGE TemplateHaskell       #-}
  15
  16 module Gargantext.Viz.Graph
  17   where
  18
  19 import Control.Lens (makeLenses)
  20 import Data.ByteString.Lazy as DBL (readFile, writeFile)
  21 import Data.Text (Text, pack)
  22 import GHC.IO (FilePath)
  23 import Gargantext.Core.Types (ListId)
  24 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
  25 import Gargantext.Database.Admin.Types.Node (NodeId)
  26 import Gargantext.Viz.Graph.Distances (GraphMetric)
  27 import Gargantext.Prelude
  28 import Test.QuickCheck (elements)
  29 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  30 import qualified Data.Aeson as DA
  31 import qualified Data.Text as T
  32 import qualified Text.Read as T
  33
  34
  35 data TypeNode = Terms | Unknown
  36   deriving (Show, Generic)
  37
  38 instance ToJSON TypeNode
  39 instance FromJSON TypeNode
  40 instance ToSchema TypeNode
  41
  42 data Attributes = Attributes { clust_default :: Int }
  43   deriving (Show, Generic)
  44 $(deriveJSON (unPrefix "") ''Attributes)
  45 instance ToSchema Attributes
  46
  47 data Node = Node { node_size  :: Int
  48                  , node_type  :: TypeNode -- TODO NgramsType | Person
  49                  , node_id    :: Text     -- TODO NgramId
  50                  , node_label :: Text
  51                  , node_x_coord :: Double
  52                  , node_y_coord :: Double
  53                  , node_attributes :: Attributes
  54                  }
  55   deriving (Show, Generic)
  56 $(deriveJSON (unPrefix "node_") ''Node)
  57 instance ToSchema Node where
  58   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  59
  60
  61 data Edge = Edge { edge_source :: Text
  62                  , edge_target :: Text
  63                  , edge_weight :: Double
  64                  , edge_confluence :: Double
  65                  , edge_id     :: Text
  66                  }
  67   deriving (Show, Generic)
  68
  69 $(deriveJSON (unPrefix "edge_") ''Edge)
  70
  71 instance ToSchema Edge where
  72   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  73
  74 ---------------------------------------------------------------
  75 data LegendField = LegendField { _lf_id :: Int
  76                                , _lf_color :: Text
  77                                , _lf_label :: Text
  78    } deriving (Show, Generic)
  79 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  80
  81 instance ToSchema LegendField where
  82   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  83
  84 makeLenses ''LegendField
  85 ---------------------------------------------------------------
  86 type Version = Int
  87 data ListForGraph =
  88   ListForGraph { _lfg_listId  :: ListId
  89                , _lfg_version :: Version
  90                } deriving (Show, Generic)
  91 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
  92
  93 instance ToSchema ListForGraph where
  94   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
  95
  96 makeLenses ''ListForGraph
  97
  98 --
  99 data GraphMetadata =
 100   GraphMetadata { _gm_title            :: Text          -- title of the graph
 101                 , _gm_metric           :: GraphMetric
 102                 , _gm_corpusId         :: [NodeId]      -- we can map with different corpus
 103                 , _gm_legend           :: [LegendField] -- legend of the Graph
 104                 , _gm_list             :: ListForGraph
 105                 , _gm_startForceAtlas  :: Bool
 106                 -- , _gm_version       :: Int
 107                 }
 108   deriving (Show, Generic)
 109 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
 110 instance ToSchema GraphMetadata where
 111   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
 112 makeLenses ''GraphMetadata
 113
 114
 115 data Graph = Graph { _graph_nodes    :: [Node]
 116                    , _graph_edges    :: [Edge]
 117                    , _graph_metadata :: Maybe GraphMetadata
 118                    }
 119   deriving (Show, Generic)
 120 $(deriveJSON (unPrefix "_graph_") ''Graph)
 121 makeLenses ''Graph
 122
 123 instance ToSchema Graph where
 124   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
 125
 126 -- | Intances for the mack
 127 instance Arbitrary Graph where
 128   arbitrary = elements $ [defaultGraph]
 129
 130 defaultGraph :: Graph
 131 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}
 132
 133
 134 -----------------------------------------------------------
 135 -- V3 Gargantext Version
 136
 137 data AttributesV3 = AttributesV3 { cl :: Int }
 138   deriving (Show, Generic)
 139 $(deriveJSON (unPrefix "") ''AttributesV3)
 140
 141 data NodeV3 = NodeV3 { no_id :: Int
 142                      , no_at :: AttributesV3
 143                      , no_s  :: Int
 144                      , no_lb :: Text
 145                      }
 146   deriving (Show, Generic)
 147 $(deriveJSON (unPrefix "no_") ''NodeV3)
 148
 149 data EdgeV3 = EdgeV3 { eo_s :: Int
 150                      , eo_t :: Int
 151                      , eo_w :: Text
 152                      }
 153   deriving (Show, Generic)
 154 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 155
 156 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 157                        , go_nodes :: [NodeV3]
 158                        }
 159   deriving (Show, Generic)
 160 $(deriveJSON (unPrefix "go_") ''GraphV3)
 161
 162
 163 -----------------------------------------------------------
 164 data HyperdataGraph =
 165   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 166                  } deriving (Show, Generic)
 167 $(deriveJSON (unPrefix "") ''HyperdataGraph)
 168
 169 defaultHyperdataGraph :: HyperdataGraph
 170 defaultHyperdataGraph = HyperdataGraph Nothing
 171
 172
 173 instance Hyperdata HyperdataGraph
 174 makeLenses ''HyperdataGraph
 175
 176 instance FromField HyperdataGraph
 177   where
 178     fromField = fromField'
 179
 180 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 181   where
 182     queryRunnerColumnDefault = fieldQueryRunnerColumn
 183
 184 -----------------------------------------------------------
 185 graphV3ToGraph :: GraphV3 -> Graph
 186 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
 187   where
 188     nodeV32node :: NodeV3 -> Node
 189     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 190                 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
 191
 192     linkV32edge :: Int -> EdgeV3 -> Edge
 193     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s')
 194                                                     (cs $ show eo_t')
 195                                                     ((T.read $ T.unpack eo_w') :: Double)
 196                                                     0.5
 197                                                     (cs $ show n)
 198
 199
 200 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 201 graphV3ToGraphWithFiles g1 g2 = do
 202   -- GraphV3 <- IO Fichier
 203   graph <- DBL.readFile g1
 204   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 205         Nothing -> panic (T.pack "no graph")
 206         Just new -> new
 207
 208   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 209
 210 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 211 readGraphFromJson fp = do
 212   graph <- liftBase $ DBL.readFile fp
 213   pure $ DA.decode graph