Draw.purs 6.57 KB
Newer Older
arturo's avatar
arturo committed
1 2 3 4 5 6
module Gargantext.Components.PhyloExplorer.Draw
  ( drawPhylo
  , highlightSource
  , unhide
  , setGlobalDependencies, setGlobalD3Reference
  ) where
arturo's avatar
arturo committed
7 8 9

import Gargantext.Prelude

arturo's avatar
arturo committed
10
import DOM.Simple (Document, Window, querySelectorAll)
arturo's avatar
arturo committed
11
import Data.Either (Either(..))
arturo's avatar
arturo committed
12 13
import Data.Foldable (for_)
import Data.FoldableWithIndex (forWithIndex_)
arturo's avatar
arturo committed
14
import Data.Maybe (Maybe(..), maybe)
arturo's avatar
arturo committed
15
import Effect (Effect)
arturo's avatar
arturo committed
16 17
import Effect.Uncurried (EffectFn1, EffectFn7, runEffectFn1, runEffectFn7)
import FFI.Simple (applyTo, getProperty, (..), (.=), (.?))
arturo's avatar
arturo committed
18
import Gargantext.Components.PhyloExplorer.Types (AncestorLink, Branch, BranchLink, GlobalTerm(..), Group(..), Link, Period, PhyloDataSet(..))
arturo's avatar
arturo committed
19 20 21
import Graphics.D3.Base (D3, D3Eff)
import Graphics.D3.Selection as D3S
import Graphics.D3.Util (ffi)
arturo's avatar
arturo committed
22

arturo's avatar
arturo committed
23
foreign import _drawPhylo :: EffectFn7
arturo's avatar
arturo committed
24 25 26 27 28 29 30
  (Array Branch)
  (Array Period)
  (Array Group)
  (Array Link)
  (Array AncestorLink)
  (Array BranchLink)
  (Array Number)
arturo's avatar
arturo committed
31
  (Unit)
arturo's avatar
arturo committed
32 33 34 35 36 37 38 39 40 41

drawPhylo ::
     Array Branch
  -> Array Period
  -> Array Group
  -> Array Link
  -> Array AncestorLink
  -> Array BranchLink
  -> Array Number
  -> Effect Unit
arturo's avatar
arturo committed
42
drawPhylo = runEffectFn7 _drawPhylo
arturo's avatar
arturo committed
43

arturo's avatar
arturo committed
44 45 46 47 48
foreign import _drawWordCloud :: forall a. EffectFn1 (Array a) Unit

drawWordCloud :: forall a. Array a -> Effect Unit
drawWordCloud = runEffectFn1 _drawWordCloud

arturo's avatar
arturo committed
49 50
-----------------------------------------------------------

arturo's avatar
arturo committed
51 52 53 54
orDie :: forall err a. Maybe a -> err -> Either err a
orDie (Just a) _   = Right a
orDie Nothing  err = Left err

arturo's avatar
arturo committed
55 56 57 58 59 60 61 62 63
-- @XXX: FFI.Simple `(...)` throws error (JavaScript issue)
--       need to decompose computation
--
--       (?) chained prototype property issue?
applyTo_ :: forall src arg res. src -> String -> Array arg -> res
applyTo_ src name args =
  let fn = getProperty name src
  in applyTo fn src args

arturo's avatar
arturo committed
64
infixl 4 applyTo_ as ~~
arturo's avatar
arturo committed
65 66 67

-- @WIP: DOM.Simple lack of "ClassList" module
addClass :: forall el. el -> Array String -> Effect Unit
arturo's avatar
arturo committed
68
addClass el args = pure $ (el .. "classList") ~~ "add" $ args
arturo's avatar
arturo committed
69 70

removeClass :: forall el. el -> Array String -> Effect Unit
arturo's avatar
arturo committed
71
removeClass el args = pure $ (el .. "classList") ~~ "remove" $ args
arturo's avatar
arturo committed
72

arturo's avatar
arturo committed
73 74 75 76
-- @WIP: "Graphics.D3.Selection" lack of "filter" function
-- @WIP: "Graphics.D3.Selection" lack of "nodes" function
selectionFilter :: forall d. String -> D3S.Selection d -> D3Eff (D3S.Selection D3S.Void)
selectionFilter = ffi ["query", "selection", ""] "selection.filter(query)"
arturo's avatar
arturo committed
77

arturo's avatar
arturo committed
78 79
selectionNodes :: forall d el. D3S.Selection d -> D3Eff (Array el)
selectionNodes = ffi ["selection", ""] "selection.nodes()"
arturo's avatar
arturo committed
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110

-----------------------------------------------------------

setGlobalDependencies :: Window -> PhyloDataSet -> Effect Unit
setGlobalDependencies w (PhyloDataSet o)
  = do
    _ <- pure $ (w .= "freq") {}
    _ <- pure $ (w .= "nbBranches") o.nbBranches
    _ <- pure $ (w .= "nbDocs") o.nbDocs
    _ <- pure $ (w .= "nbFoundations") o.nbFoundations
    _ <- pure $ (w .= "nbGroups") o.nbGroups
    _ <- pure $ (w .= "nbPeriods") o.nbPeriods
    _ <- pure $ (w .= "nbTerms") o.nbTerms
    _ <- pure $ (w .= "sources") o.sources
    _ <- pure $ (w .= "terms") []
    _ <- pure $ (w .= "timeScale") o.timeScale
    _ <- pure $ (w .= "weighted") o.weighted

    (freq :: Array Int)         <- pure $ w .. "freq"
    (terms :: Array GlobalTerm) <- pure $ w .. "terms"

    for_ o.groups \(Group g) -> do

      let
        f = g.foundation
        l = g.label

      forWithIndex_ f \idx val ->
        let
          idx' = show idx
          val' = show val
arturo's avatar
arturo committed
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
        in
          -- For each entries in group.foundation array,
          -- increment consequently the global window.keys array
          case (freq .? val') of
            Nothing -> pure $ (freq .= val') 0
            Just v  -> pure $ (freq .= val') (v +1)
        *>
          -- For each entries in group.foundation array,
          -- if the global window.terms does not have it in property,
          -- append an item to the global window.terms
          case (terms .? val') of
            Just _  -> pure unit
            Nothing -> void <<< pure $ (terms .= val') $ GlobalTerm
              { label: l .. idx'
              , fdt  : val'
              }

arturo's avatar
arturo committed
128 129 130 131 132
    -- Use FFI native `Array.flat` method (not mutating its caller in this
    -- context)
    void do
      new <- pure $ (terms ~~ "flat") []
      pure $ (w .= "terms") new
arturo's avatar
arturo committed
133

arturo's avatar
arturo committed
134
-- @XXX: prevent PureScript from not injecting D3
arturo's avatar
arturo committed
135 136
setGlobalD3Reference :: Window -> D3 -> Effect Unit
setGlobalD3Reference window d3 = void $ pure $ (window .= "d3") d3
arturo's avatar
arturo committed
137 138 139

-----------------------------------------------------------

arturo's avatar
arturo committed
140 141 142 143 144 145 146 147
unhide :: Document -> String -> Effect Unit
unhide d s = do
  setText s   `toElements` "#phyloName"
  turnVisible `toElements` "#phyloName"
  turnVisible `toElements` ".reset"
  turnVisible `toElements` ".label"
  turnVisible `toElements` ".heading"
  turnVisible `toElements` ".export"
arturo's avatar
arturo committed
148 149

  where
arturo's avatar
arturo committed
150 151 152 153 154 155 156
    toElements fn query = querySelectorAll d query >>= flip for_ fn

    turnVisible el = do
      style <- pure $ (el .. "style")
      pure $ (style .= "visibility") "visible"

    setText name el = pure $ (el .= "innerHTML") name
arturo's avatar
arturo committed
157 158 159

-----------------------------------------------------------

arturo's avatar
arturo committed
160 161
highlightSource :: Window -> String -> Effect Unit
highlightSource window value =
arturo's avatar
arturo committed
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
  let
    hasHighlight = maybe false identity (window .? "highlighted")
    hasLdView    = maybe false identity (window .? "ldView")

  in do
    groups <- D3S.rootSelectAll ".group-inner"

    if hasHighlight
    then
          selectionFilter ".source-focus" groups
      >>= selectionNodes
      >>= flip for_ (flip addClass [ "group-unfocus" ])
    else
      pure unit


    -- unselected all the groups
    _ <-  selectionNodes groups
      >>= flip for_ (flip removeClass [ "source-focus" ])

    if hasLdView
    then
          selectionNodes groups
      >>= flip for_ (fill "#f5eee6")
    else
          selectionNodes groups
      >>= flip for_ (fill "#fff")

    _ <-  D3S.rootSelectAll ".peak"
      >>= D3S.classed "peak-focus-source" false


    -- select the relevant ones
    if (value == "unselect")
    then
      pure unit
arturo's avatar
arturo committed
198 199 200
    else do
      arr <- selectionFilter (".source-" <> value) groups
        >>= selectionNodes
arturo's avatar
arturo committed
201

arturo's avatar
arturo committed
202 203
      drawWordCloud arr
      for_ arr selectNodeGroup
arturo's avatar
arturo committed
204 205 206 207 208 209 210 211 212

  where

    fill :: forall el. String -> el -> Effect Unit
    fill hex el = do
      style <- pure $ (el .. "style")
      pure $ (style .= "fill") hex


arturo's avatar
arturo committed
213
    selectNodeGroup :: forall el. el -> Effect Unit
arturo's avatar
arturo committed
214 215 216 217 218
    selectNodeGroup el = do
      removeClass el [ "group-unfocus" ]
      addClass el [ "source-focus" ]
      fill "#a6bddb" el

arturo's avatar
arturo committed
219
      bid <- pure $ (el ~~ "getAttribute") [ "bId" ]
arturo's avatar
arturo committed
220 221 222 223

      void $
            D3S.rootSelect ("#peak-" <> bid)
        >>= D3S.classed "peak-focus-source" true