Skip to content

H
haskell-gargantext
Commit 35b8b782 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[graph] some screenshot work

parent 357822b0
Hide whitespace changes
Inline Side-by-side
Showing with 76 additions and 59 deletions
src/Gargantext/API/Prelude.hs
View file @ 35b8b782
......@@ -33,6 +33,10 @@ import Crypto.JOSE.Error as Jose
import Data.Aeson.Types
import Data.Typeable
import Data.Validity
import Servant
import Servant.Job.Async
import Servant.Job.Core (HasServerError(..), serverError)
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Settings
import Gargantext.API.Ngrams
......@@ -41,9 +45,6 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Tree
import Gargantext.Prelude
import Servant
import Servant.Job.Async (HasJobEnv)
import Servant.Job.Core (HasServerError(..), serverError)
class HasJoseError e where
_JoseError :: Prism' e Jose.Error
......
src/Gargantext/Text/Metrics/TFICF.hs
View file @ 35b8b782
......@@ -23,13 +23,14 @@ module Gargantext.Text.Metrics.TFICF ( TFICF
)
where
import Data.Text (Text)
import Gargantext.Prelude
import Data.Set (Set)
import Gargantext.Core.Types (Ordering(..))
import qualified Data.List as List
import Data.Map.Strict (Map, toList)
import qualified Data.Ord as DO (Down(..))
import qualified Data.List as List
import Data.Set (Set)
import Data.Text
import Gargantext.Prelude
import Gargantext.Core.Types (Ordering(..))
path :: Text
path = "[G.T.Metrics.TFICF]"
......@@ -49,7 +50,7 @@ tficf :: TficfContext Count Total
tficf (TficfInfra (Count ic) (Total it) )
(TficfSupra (Count sc) (Total st) )
| it >= ic && st >= sc && it <= st = (ic/it) / log (sc/st)
| otherwise = panic $ "[ERR]" <> path <>" Frequency impossible"
| otherwise = panic $ "[ERR]" <> path <> " Frequency impossible"
tficf _ _ = panic $ "[ERR]" <> path <> "Undefined for these contexts"
......
src/Gargantext/Viz/Graph.hs
View file @ 35b8b782
......@@ -97,12 +97,13 @@ makeLenses ''ListForGraph
--
data GraphMetadata =
GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_metric :: GraphMetric
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
-- , _gm_version :: Int
GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_metric :: GraphMetric
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
, _gm_startForceAtlas :: Bool
-- , _gm_version :: Int
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
......
src/Gargantext/Viz/Graph/API.hs
View file @ 35b8b782
......@@ -55,8 +55,8 @@ import Gargantext.Viz.Graph.Distances (Distance(..), GraphMetric(..))
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
type GraphAPI = Get '[JSON] Graph
:<|> "async" :> GraphAsyncAPI
:<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
:<|> GraphAsyncAPI
:<|> "versions" :> GraphVersionsAPI
data GraphVersions =
......@@ -69,10 +69,10 @@ instance ToJSON GraphVersions
instance ToSchema GraphVersions
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI u n = getGraph u n
:<|> getGraphGexf u n
:<|> graphAsync u n
:<|> graphVersionsAPI u n
graphAPI u n = getGraph u n
:<|> graphAsync u n
:<|> getGraphGexf u n
:<|> graphVersionsAPI u n
------------------------------------------------------------------------
getGraph :: UserId -> NodeId -> GargNoServer Graph
......@@ -90,8 +90,10 @@ getGraph _uId nId = do
case graph of
Nothing -> do
graph' <- computeGraph cId Conditional NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph')
pure $ trace "[G.V.G.API] Graph empty, computing" graph'
mt <- defaultGraphMetadata cId "Title" repo
let graph'' = set graph_metadata (Just mt) graph'
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure $ trace "[G.V.G.API] Graph empty, computing" graph''
Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" graph'
......@@ -100,11 +102,8 @@ recomputeGraph :: UserId -> NodeId -> Distance -> GargNoServer Graph
recomputeGraph _uId nId d = do
nodeGraph <- getNodeWith nId HyperdataGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let listVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_list
. lfg_version
let graphMetadata = graph ^? _Just . graph_metadata . _Just
let listVersion = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
repo <- getRepo
let v = repo ^. r_version
......@@ -115,15 +114,18 @@ recomputeGraph _uId nId d = do
case graph of
Nothing -> do
graph' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph')
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph'
mt <- defaultGraphMetadata cId "Title" repo
let graph'' = set graph_metadata (Just mt) graph'
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
Just graph' -> if listVersion == Just v
then pure graph'
else do
graph'' <- computeGraph cId d NgramsTerms repo
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph''
let graph''' = set graph_metadata graphMetadata graph''
_ <- updateHyperdata nId (HyperdataGraph $ Just graph''')
pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
-- TODO use Database Monad only here ?
......@@ -147,49 +149,61 @@ computeGraph cId d nt repo = do
graph <- liftBase $ cooc2graph d 0 myCooc
pure graph
let metadata = GraphMetadata "Title"
Order1
[cId]
[ LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
(ListForGraph lId (repo ^. r_version))
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
pure $ set graph_metadata (Just metadata) graph
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
-> NgramsRepo
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo = do
lId <- defaultList cId
pure $ GraphMetadata {
_gm_title = t
, _gm_metric = Order1
, _gm_corpusId = [cId]
, _gm_legend = [
LegendField 1 "#FFF" "Cluster1"
, LegendField 2 "#FFF" "Cluster2"
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. r_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
------------------------------------------------------------
type GraphAsyncAPI = Summary "Update graph"
:> "async"
:> AsyncJobsAPI JobLog () JobLog
type GraphAsyncAPI = Summary "Recompute graph"
:> "recompute"
:> AsyncJobsAPI JobLog () JobLog
graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
graphAsync u n =
serveJobsAPI $
JobFunction (\_ log' -> graphAsync' u n (liftBase . log'))
JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
graphAsync' :: UserId
-> NodeId
-> (JobLog -> GargNoServer ())
-> GargNoServer JobLog
graphAsync' u n logStatus = do
graphRecompute :: UserId
-> NodeId
-> (JobLog -> GargNoServer ())
-> GargNoServer JobLog
graphRecompute u n logStatus = do
logStatus JobLog { _scst_succeeded = Just 0
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
_g <- trace (show u) $ recomputeGraph u n Conditional
pure JobLog { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
------------------------------------------------------------
type GraphVersionsAPI = Summary "Graph versions"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment