Skip to content

haskell-gargantext
haskell-gargantext
Commit d757a283 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[GRAPH] again without filters.

parent 5dc4c39f
Hide whitespace changes
Inline Side-by-side
Showing with 125 additions and 105 deletions
src/Gargantext/API/Node.hs
View file @ d757a283
......@@ -38,6 +38,7 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad ((>>))
--import System.IO (putStrLn, readFile)
--import qualified Data.Map as Map
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text())
import Data.Swagger
......@@ -55,11 +56,12 @@ import Gargantext.Database.Node.Children (getChildren)
import qualified Gargantext.Database.Node.Update as U (update, Update(..))
import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
import Gargantext.Database.Metrics.Count (getCoocByDocDev)
import Gargantext.Database.Metrics.Count (getNgramsByNode)
import Gargantext.Database.Schema.Node (defaultList)
import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
import Gargantext.Text.Metrics.Count (coocOn)
-- Graph
import Gargantext.Text.Flow (cooc2graph)
import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
......@@ -289,8 +291,10 @@ graphAPI nId = do
]
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
lId <- defaultList cId
myCooc <- getCoocByDocDev cId lId
_lId <- defaultList cId
-- lId' <- listsWith masterUser
--myCooc <- getCoocByDocDev cId lId -- (lid' <> [lId])
myCooc <- coocOn identity <$> getNgramsByNode cId NgramsTerms
liftIO $ set graph_metadata (Just metadata)
<$> cooc2graph myCooc
......
src/Gargantext/Database/Metrics/Count.hs
View file @ d757a283
......@@ -11,6 +11,7 @@ Count Ngrams by Context
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
......@@ -18,18 +19,25 @@ Count Ngrams by Context
module Gargantext.Database.Metrics.Count where
import Control.Arrow (returnA)
import Control.Lens (view)
import Data.Map.Strict (Map, fromListWith, elems)
import Data.Text (Text)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core.Types.Main (listTypeId, ListType(..))
import Gargantext.Database.Queries.Join (leftJoin4)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Ngrams (NgramsId, NgramsType(..), ngramsTypeId, Ngrams(..), NgramsIndexed(..), ngrams, ngramsTerms)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.Node (HasNodeError(..))
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Schema.NodeNode
import Gargantext.Database.Types.Node -- (ListId, CorpusId, NodeId)
import Gargantext.Database.Utils
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Prelude
import Gargantext.Core.Types.Main (listTypeId, ListType(..))
import Gargantext.Text.Metrics.Count (Coocs, coocOn)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Database.Types.Node (ListId, CorpusId)
import Gargantext.Database.Types.Node (NodeId)
import Gargantext.Database.Schema.Ngrams (NgramsId, NgramsType(..), ngramsTypeId, Ngrams(..), NgramsIndexed(..), ngrams, ngramsTerms)
import Opaleye
getCoocByDocDev :: HasNodeError err => CorpusId -> ListId -> Cmd err (Map ([Text], [Text]) Int)
getCoocByDocDev cId lId = coocOn (\n-> [ view ( ngrams . ngramsTerms) n]) <$> getNgramsByDoc cId lId
......@@ -65,3 +73,56 @@ getNgramsByDocDb cId lId = runPGSQuery query params
AND list.ngrams_type = ? -- NgramsTypeId
|]
getNgramsByNode :: NodeId -> NgramsType -> Cmd err [[Text]]
getNgramsByNode nId nt = elems
<$> fromListWith (<>)
<$> map (\(i,t) -> (i,[t]))
<$> getNgramsByNodeIndexed nId nt
-- | TODO add join with nodeNodeNgram (if it exists)
getNgramsByNodeIndexed :: NodeId -> NgramsType -> Cmd err [(NodeId, Text)]
getNgramsByNodeIndexed nId nt = runOpaQuery (select' nId)
where
select' nId' = proc () -> do
(ng,(nng,(_,n))) <- getNgramsByNodeIndexedJoin -< ()
restrict -< _node_id n .== toNullable (pgNodeId nId')
restrict -< _nn_ngramsType nng .== toNullable (pgNgramsTypeId $ ngramsTypeId nt)
returnA -< (_nn_node_id nng, ngrams_terms ng)
--}
getNgramsByNodeIndexedJoin :: Query ( NgramsRead
, (NodeNgramReadNull
, (NodeNodeReadNull
, NodeReadNull
)
)
)
getNgramsByNodeIndexedJoin = leftJoin4 queryNodeTable
queryNodeNodeTable
queryNodeNgramTable
queryNgramsTable
c1 c2 c3
where
c1 :: (NodeNodeRead, NodeRead) -> Column PGBool
c1 (nn,n) = nodeNode_node1_id nn .== _node_id n
c2 :: ( NodeNgramRead
, (NodeNodeRead
, NodeReadNull
)
) -> Column PGBool
c2 (nng,(nn',_)) = (_nn_node_id nng) .== nodeNode_node2_id nn'
c3 :: ( NgramsRead
, ( NodeNgramRead
, ( NodeNodeReadNull
, NodeReadNull
)
)
) -> Column PGBool
c3 (ng,(nng',(_,_))) = (ngrams_id ng) .== _nn_ngrams_id nng'
--}
src/Gargantext/Database/Queries/Join.hs
View file @ d757a283
......@@ -30,7 +30,6 @@ module Gargantext.Database.Queries.Join
import Control.Applicative ((<*>))
import Control.Arrow ((>>>))
import Data.Profunctor.Product.Default
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.NodeNode
import Gargantext.Prelude
......@@ -51,32 +50,7 @@ join3 q1 q2 q3 cond = ((,,) <$> q1 <*> q2 <*> q3) >>> keepWhen cond
------------------------------------------------------------------------
leftJoin3Ex :: Query (NodeRead, (NodeNodeReadNull, NodeReadNull))
leftJoin3Ex = leftJoin3 queryNodeNodeTable queryNodeTable queryNodeTable cond12 cond23
where
cond12 = undefined
cond23 :: (NodeRead, (NodeNodeRead, NodeReadNull)) -> Column PGBool
cond23 = undefined
leftJoin3 :: ( Default Unpackspec columnsL1 columnsL1
, Default Unpackspec columnsL2 columnsL2
, Default Unpackspec columnsL3 columnsL3
, Default Unpackspec nullableColumnsL2 nullableColumnsL2
, Default NullMaker columnsL2 nullableColumnsL2
, Default NullMaker (columnsL1, nullableColumnsL2) nullableColumnsL3
)
=>
Query columnsL1 -> Query columnsL2 -> Query columnsL3
-> ((columnsL1, columnsL2) -> Column PGBool)
-> ((columnsL3, (columnsL1, nullableColumnsL2)) -> Column PGBool)
-> Query (columnsL3, nullableColumnsL3)
leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q1 q2 cond12) cond23
leftJoin3'
leftJoin3
:: (Default Unpackspec fieldsL1 fieldsL1,
Default Unpackspec fieldsL2 fieldsL2,
Default Unpackspec nullableFieldsR1 nullableFieldsR1,
......@@ -89,35 +63,7 @@ leftJoin3'
-> ((fieldsL2, fieldsR) -> Column PGBool)
-> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
-> Opaleye.Select (fieldsL1, nullableFieldsR2)
leftJoin3' q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q2 q1 cond12) cond23
--{-
leftJoin4' :: Query (NodeRead, (NodeReadNull, (NgramsReadNull, NodeReadNull)))
leftJoin4' = leftJoin4 queryNgramsTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
where
cond12 :: (NgramsRead, NodeRead) -> Column PGBool
cond12 = undefined
cond23 :: (NodeRead, (NgramsRead, NodeReadNull)) -> Column PGBool
cond23 = undefined
cond34 :: (NodeRead, (NodeRead, (NgramsReadNull, NodeReadNull))) -> Column PGBool
cond34 = undefined
{-
rightJoin4' :: Query (((NodeReadNull, NodeReadNull), NodeReadNull), NodeRead)
rightJoin4' = rightJoin4 queryNodeTable queryNodeTable queryNodeTable queryNodeTable cond12 cond23 cond34
where
cond12 :: (NodeRead, NodeRead) -> Column PGBool
cond12 = undefined
cond23 :: ((NodeReadNull, NodeRead), NodeRead) -> Column PGBool
cond23 = undefined
cond34 :: (((NodeReadNull, NodeReadNull), NodeRead), NodeRead) -> Column PGBool
cond34 = undefined
--}
leftJoin3 q1 q2 q3 cond12 cond23 = leftJoin q3 (leftJoin q2 q1 cond12) cond23
leftJoin4
......@@ -130,18 +76,16 @@ leftJoin4
Default NullMaker fieldsR nullableFieldsR2,
Default NullMaker (fieldsL2, nullableFieldsR1) nullableFieldsR3,
Default NullMaker (fieldsL3, nullableFieldsR2) nullableFieldsR1) =>
Opaleye.Select fieldsL3
-> Opaleye.Select fieldsR
Opaleye.Select fieldsR
-> Opaleye.Select fieldsL3
-> Opaleye.Select fieldsL2
-> Opaleye.Select fieldsL1
-> ((fieldsL3, fieldsR) -> Column PGBool)
-> ((fieldsL2, (fieldsL3, nullableFieldsR2)) -> Column PGBool)
-> ((fieldsL1, (fieldsL2, nullableFieldsR1)) -> Column PGBool)
-> Opaleye.Select (fieldsL1, nullableFieldsR3)
leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q1 q2 cond12) cond23) cond34
leftJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = leftJoin q4 (leftJoin q3 (leftJoin q2 q1 cond12) cond23) cond34
-- rightJoin4 q1 q2 q3 q4 cond12 cond23 cond34 = rightJoin q4 (rightJoin q3 (rightJoin q1 q2 cond12) cond23) cond34
--{-
leftJoin5' :: Query (NodeRead, (NodeReadNull, (NodeReadNull, (NodeNodeReadNull, NodeSearchReadNull))))
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ d757a283
......@@ -56,8 +56,8 @@ import qualified Data.Set as DS
import qualified Database.PostgreSQL.Simple as PGS
type NgramsTerms = Text
type NgramsId = Int
type NgramsTerms = Text
type Size = Int
data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
......@@ -263,12 +263,12 @@ type NgramsTableParamMaster = NgramsTableParam
data NgramsTableData = NgramsTableData { _ntd_id :: Int
, _ntd_parent_id :: Maybe Int
, _ntd_terms :: Text
, _ntd_n :: Int
, _ntd_listType :: Maybe ListType
, _ntd_weight :: Double
} deriving (Show)
, _ntd_parent_id :: Maybe Int
, _ntd_terms :: Text
, _ntd_n :: Int
, _ntd_listType :: Maybe ListType
, _ntd_weight :: Double
} deriving (Show)
......
src/Gargantext/Database/Schema/Node.hs
View file @ d757a283
......@@ -102,6 +102,10 @@ instance FromField HyperdataGraph
instance FromField HyperdataAnnuaire
where
fromField = fromField'
instance FromField (NodeId, Text)
where
fromField = fromField'
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGJsonb HyperdataAny
where
......@@ -147,6 +151,11 @@ instance QueryRunnerColumnDefault PGInt4 NodeId
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
-- WIP
......
src/Gargantext/Text/Flow.hs
View file @ d757a283
......@@ -20,26 +20,26 @@ module Gargantext.Text.Flow
--import qualified Data.Array.Accelerate as A
--import qualified Data.Set as DS
import Control.Monad.Reader
--import Control.Monad.Reader
import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes)
import qualified Data.Map.Strict as M
--import Data.Maybe (catMaybes)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.IO (readFile)
--import Data.Text.IO (readFile)
import Database.PostgreSQL.Simple (Connection)
import GHC.IO (FilePath)
import Gargantext.Core (Lang)
--import Gargantext.Core (Lang)
import Gargantext.Core.Types (CorpusId)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Types.Node
--import Gargantext.Database.Schema.Node
--import Gargantext.Database.Types.Node
import Gargantext.Prelude
import Gargantext.Text.Context (splitBy, SplitContext(Sentences))
--import Gargantext.Text.Context (splitBy, SplitContext(Sentences))
import Gargantext.Text.Metrics (filterCooc, FilterConfig(..), Clusters(..), SampleBins(..), DefaultValue(..), MapListSize(..), InclusionSize(..))
import Gargantext.Text.Metrics.Count (cooc)
import Gargantext.Text.Parsers.CSV
import Gargantext.Text.Terms (TermType, extractTerms)
--import Gargantext.Text.Metrics.Count (coocOn)
--import Gargantext.Text.Parsers.CSV
--import Gargantext.Text.Terms (TermType, extractTerms)
import Gargantext.Viz.Graph (Graph(..), data2graph)
import Gargantext.Viz.Graph.Bridgeness (bridgeness)
import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
......@@ -76,7 +76,7 @@ data TextFlow = CSV FilePath
| DBV3 Connection CorpusId
| Query T.Text
{-
textFlow :: TermType Lang -> TextFlow -> IO Graph
textFlow termType workType = do
contexts <- case workType of
......@@ -104,18 +104,19 @@ textFlow' termType contexts = do
-- Bulding the map list
-- compute copresences of terms, i.e. cooccurrences of terms in same context of text
-- Cooc = Map (Term, Term) Int
let myCooc1 = cooc myterms
let myCooc1 = coocOn (_terms_label) myterms
--printDebug "myCooc1 size" (M.size myCooc1)
-- Remove Apax: appears one time only => lighting the matrix
let myCooc2 = M.filter (>0) myCooc1
let myCooc2 = Map.filter (>0) myCooc1
--printDebug "myCooc2 size" (M.size myCooc2)
--printDebug "myCooc2" myCooc2
g <- cooc2graph myCooc2
pure g
-}
-- TODO use Text only here instead of [Text]
cooc2graph :: (Map ([Text], [Text]) Int) -> IO Graph
cooc2graph :: (Map (Text, Text) Int) -> IO Graph
cooc2graph myCooc = do
--printDebug "myCooc" myCooc
-- Filtering terms with inclusion/Exclusion and Specificity/Genericity scores
......@@ -137,7 +138,7 @@ cooc2graph myCooc = do
--printDebug "myCooc4 size" $ M.size myCooc4
--printDebug "myCooc4" myCooc4
let matCooc = map2mat (0) (M.size ti) myCooc4
let matCooc = map2mat (0) (Map.size ti) myCooc4
--printDebug "matCooc shape" $ A.arrayShape matCooc
--printDebug "matCooc" matCooc
......@@ -148,19 +149,19 @@ cooc2graph myCooc = do
--printDebug "distanceMat" distanceMat
--let distanceMap = M.filter (>0) $ mat2map distanceMat
let distanceMap = M.map (\_ -> 1) $ M.filter (>0) $ mat2map distanceMat
let distanceMap = Map.map (\_ -> 1) $ Map.filter (>0) $ mat2map distanceMat
--printDebug "distanceMap size" $ M.size distanceMap
--printDebug "distanceMap" distanceMap
-- let distance = fromIndex fi distanceMap
--printDebug "distance" $ M.size distance
partitions <- case M.size distanceMap > 0 of
partitions <- case Map.size distanceMap > 0 of
True -> cLouvain distanceMap
False -> panic "Text.Flow: DistanceMap is empty"
-- Building : -> Graph -> JSON
--printDebug "partitions" $ DS.size $ DS.fromList $ map (l_community_id) partitions
--printDebug "partitions" partitions
let distanceMap' = bridgeness 300 partitions distanceMap
pure $ data2graph (M.toList ti) myCooc4 distanceMap' partitions
pure $ data2graph (Map.toList ti) myCooc4 distanceMap' partitions
src/Gargantext/Text/Metrics/Count.hs
View file @ d757a283
......@@ -108,10 +108,10 @@ labelPolicy m g = case _terms_label <$> fst <$> maximumWith snd <$> DMS.toList
Nothing -> panic $ "Label of Grouped not found: " <> (pack $ show g)
-}
coocOn :: Ord b => (a -> b) -> [[a]] -> Map (b, b) Coocs
coocOn :: Ord b => (a -> b) -> [[a]] -> Map (b, b) Int
coocOn f as = DMS.unionsWith (+) $ map (coocOn' f) as
coocOn' :: Ord b => (a -> b) -> [a] -> Map (b, b) Coocs
coocOn' :: Ord b => (a -> b) -> [a] -> Map (b, b) Int
coocOn' fun ts = DMS.fromListWith (+) xs
where
ts' = List.nub $ map fun ts
......
src/Gargantext/Viz/Graph.hs
View file @ d757a283
......@@ -36,7 +36,6 @@ import qualified Data.Map.Strict as M
import Data.Swagger
import Gargantext.Prelude
import Gargantext.Core.Types (Label)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Types.Node (NodeId)
......@@ -164,9 +163,9 @@ $(deriveJSON (unPrefix "go_") ''GraphV3)
----------------------------------------------------------
-- | 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]
data2graph :: [(Text, Int)] -> Map (Int, Int) Int
-> Map (Int, Int) Double
-> [LouvainNode]
-> Graph
data2graph labels coocs distance partitions = Graph nodes edges Nothing
where
......@@ -174,7 +173,7 @@ data2graph labels coocs distance partitions = Graph nodes edges Nothing
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_label = l
, node_attributes =
Attributes { clust_default = maybe 0 identity
(M.lookup n community_id_by_node_id) } }
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ d757a283
......@@ -32,7 +32,7 @@ module Gargantext.Viz.Phylo.Tools where
import Data.Set (Set)
import Data.Map (Map)
import Data.Map as Map hiding (Map)
import qualified Data.Map as Map hiding (Map)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Example
......@@ -44,6 +44,7 @@ type MinSize = Int
-- | Building a phylo
-- (Indicative and schematic function)
{-
buildPhylo :: Support -> MinSize
-> Map Clique Support -> Phylo
buildPhylo s m mcs = level2Phylo
......@@ -51,8 +52,9 @@ buildPhylo s m mcs = level2Phylo
. clusters2group
. map clique2cluster
. filterCliques s m
-}
level2Phylo :: PhyloLevel -> Phylo -> Phylo
level2Phylo :: [PhyloLevel] -> Phylo -> Phylo
level2Phylo = undefined
groups2level :: [PhyloGroup] -> PhyloLevel
......
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