update with gate summary hierarchy text output

krcurtis · Aug 24, 2022 · 2e7733b · 2e7733b
1 parent f2fc66f
commit 2e7733b
Show file tree

Hide file tree

Showing 3 changed files with 198 additions and 4 deletions.
diff --git a/USAGE.txt b/USAGE.txt
@@ -1,8 +1,10 @@
 Usage:
-  extract-gating-ml extract-global -i=<file> -o=<file>
-  extract-gating-ml extract-tube -s=<slabel> -t=<tlabel> -i=<file> -o=<file>  
+  extract-gating-ml extract-global -i=<diva_xml> -o=<gatingml_output_file>
+  extract-gating-ml extract-tube -s=<slabel> -t=<tlabel> -i=<diva_xml> -o=<gatingml_output_file>
   extract-gating-ml summary -i=<diva_xml>
-  extract_gating-ml summary-comp-channels -i=<diva_xml>
+  extract-gating-ml summary-comp-channels -i=<diva_xml>
+  extract-gating-ml summary-global-gates -i=<diva_xml>
+  extract-gating-ml summary-tube-gates  -s=<slabel> -t=<tlabel> -i=<diva_xml>
 
 Options:
   -h --help                 show this help text

diff --git a/app/Main.hs b/app/Main.hs
@@ -79,13 +79,31 @@ main = do
     diva_info <- load_diva_info diva_file
     show_diva_info diva_info
 
+
   when (args `isPresent` (command "summary-comp-channels")) $ do
     diva_file <- args `getArgOrExit` (longOption "input_diva_xml")
     diva_info <- load_diva_info diva_file
     show_all_compensated_channels diva_info
 
 
-
+  when (args `isPresent` (command "summary-global-gates")) $ do
+    diva_file <- args `getArgOrExit` (longOption "input_diva_xml")
+    diva_info <- load_diva_info diva_file
+    show_hierarchy (di_global_worksheet_gates diva_info)
+
+
+  when (args `isPresent` (command "summary-tube-gates")) $ do
+    diva_file <- args `getArgOrExit` (longOption "input_diva_xml")
+    diva_info <- load_diva_info diva_file
+    specimen <- args `getArgOrExit` (longOption "specimen")
+    tube_label <- args `getArgOrExit` (longOption "tube")    
+
+    let diva_gates = find_specimen_tube_gates diva_info specimen tube_label
+    if isNothing diva_gates
+      then error $ "ERROR specimen and tube combination was not found: " <> specimen <> "/" <> tube_label
+      else show_hierarchy (fromJust diva_gates)
+
+
   when (args `isPresent` (command "extract-global")) $ do
     diva_file <- args `getArgOrExit` (longOption "input_diva_xml")
     output_file <- args `getArgOrExit` (longOption "output_file")
@@ -95,6 +113,7 @@ main = do
         xml_root = gates `deepseq` to_xml gates
     xml_to_file output_file xml_root
 
+
   when (args `isPresent` (command "extract-tube")) $ do
     diva_file <- args `getArgOrExit` (longOption "input_diva_xml")
     output_file <- args `getArgOrExit` (longOption "output_file")

diff --git a/src/QueryDiva.hs b/src/QueryDiva.hs
@@ -19,6 +19,19 @@ import qualified Data.List as L
 import ParseDiva
 
 
+--------------------------------------------------------------------------------
+
+data GateNode = GateNode { gn_label :: T.Text
+                         , gn_gate :: DivaGate
+                         , gn_branches :: [ GateNode ]
+                         }
+               | RootNode { rn_label :: T.Text
+                          , rn_branches :: [GateNode]
+                          }
+  deriving (Show, Eq)
+
+
+
 --------------------------------------------------------------------------------
 
 show_tube_gates :: DivaInfo -> IO ()
@@ -85,3 +98,163 @@ show_all_compensated_channels DivaInfo{..} = do
 {-
 show_gates_with_same_name :: DivaInfo -> String -> IO ()
 -}
+
+
+--------------------------------------------------------------------------------
+-- Gate Hierarchy stuff
+-- assume gates in order in list
+-- assumes Diva Gates have parent IDs encoded as the full path like "All Events\P1\P2\P3\P4\P5\P6\P7\P8"
+
+diva_default_root_node = RootNode "All Events" []
+
+add_node_to_hierarchy :: GateNode -> [T.Text] -> DivaGate -> GateNode
+
+add_node_to_hierarchy (RootNode root_label branches) (x:[]) g | root_label == x = root'
+  where
+    label = dg_name g    
+    (node, other_branches) = L.partition (\a_node -> gn_label a_node == label) branches
+    node' = case node of
+              [] -> GateNode label g []
+              _ -> error $ "ERROR multiple nodes found with label " <> (T.unpack label)
+    branches' = node' : other_branches
+    root' = RootNode root_label branches'
+
+add_node_to_hierarchy (RootNode root_label branches) (x:y:ys) g | root_label == x = root'
+  where
+    (node_list, other_branches) = L.partition (\a_node -> gn_label a_node == y) branches
+    node' = case node_list of
+              [] -> error $ "ERROR Expected intermediate node " <> (T.unpack y) <> " but node was not found along path " <> (T.unpack . dg_parent $ g)
+              [gate_node] -> add_node_to_hierarchy gate_node ys g
+              _ -> error $ "ERROR multiple nodes found with label " <> (T.unpack y)
+    branches' = node' : other_branches
+    root' = RootNode root_label branches'
+
+
+add_node_to_hierarchy (GateNode label gate branches) [] g = node'
+  where
+    (node, other_branches) = L.partition (\a_node -> gn_label a_node == dg_name g) branches
+    leaf_node = case node of
+                  [] -> GateNode (dg_name g) g []
+                  _ -> error $ "ERROR multiple nodes found with label " <> (T.unpack . dg_name $ g)
+    branches' = leaf_node : other_branches
+    node' = GateNode label gate branches'
+
+add_node_to_hierarchy (GateNode label gate branches) (y:ys) g = node'
+  where
+    (node, other_branches) = L.partition (\a_node -> gn_label a_node == y) branches
+    intermediate_node = case node of
+                          [] -> error $ "ERROR Expected intermediate node " <> (T.unpack y) <> " but node was not found along path " <> (T.unpack . dg_parent $ g)
+                          [gate_node] -> add_node_to_hierarchy gate_node ys g
+                          _ -> error $ "ERROR multiple nodes found with label " <> (T.unpack y)
+    branches' = intermediate_node : other_branches
+    node' = GateNode label gate branches'
+
+
+
+
+build_hierarchy :: GateNode -> [DivaGate] -> GateNode
+build_hierarchy root [] = root
+build_hierarchy root (x:xs) = build_hierarchy root' xs
+  where
+    node_path = T.splitOn "\\" (dg_parent x)
+    root' = add_node_to_hierarchy root node_path x
+
+
+brief_gate_info :: DivaGate -> String
+brief_gate_info gate | (r_type . dg_region $ gate) == RectangleRegion = (T.unpack . dg_name $ gate) <> " Rectangle [" <> (T.unpack . r_xparam . dg_region $ gate) <> ", " <> (T.unpack . r_yparam . dg_region $ gate) <> "]"
+brief_gate_info gate | (r_type . dg_region $ gate) == PolygonRegion = (T.unpack . dg_name $ gate) <> " Polygon [" <> (T.unpack . r_xparam . dg_region $ gate) <> ", " <> (T.unpack . r_yparam . dg_region $ gate) <> "], n_points: " <> (show . length . r_points . dg_region $ gate)
+brief_gate_info gate | (r_type . dg_region $ gate) == IntervalRegion = (T.unpack . dg_name $ gate) <> " Interval [" <> (T.unpack . r_xparam . dg_region $ gate) <> ", " <> (T.unpack . r_yparam . dg_region $ gate) <> "]"
+brief_gate_info gate | (r_type . dg_region $ gate) == UnknownRegion = (T.unpack . dg_name $ gate) <> " Unknown [" <> (T.unpack . r_xparam . dg_region $ gate) <> ", " <> (T.unpack . r_yparam . dg_region $ gate) <> "]"
+
+
+data BranchDisplay = NotVisible | Continues | NodeHere | LastNode
+
+marking_string :: BranchDisplay -> String
+marking_string NotVisible = "    "
+marking_string Continues  = "|   "
+marking_string NodeHere   = "|-- "
+marking_string LastNode   = "`-- "
+
+
+-- for xs, this is from right to left
+hierarchy_indent_string :: [BranchDisplay] -> String
+hierarchy_indent_string [] = []
+hierarchy_indent_string (x:xs) = hierarchy_indent_string xs ++ marking_string x
+
+
+build_text_hierarchy :: [BranchDisplay] -> [GateNode] -> [String]
+build_text_hierarchy previous_levels [] = []
+build_text_hierarchy [] ((RootNode label branches):[]) = (T.unpack label) : build_text_hierarchy  [] branches
+build_text_hierarchy [] ((GateNode label g branches):[]) = current : build_text_hierarchy levels' branches
+  where
+    levels' = LastNode : []
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+
+build_text_hierarchy [] ((GateNode label g branches):gs) = text ++ build_text_hierarchy [] gs
+  where
+    levels' = NodeHere : []
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+    text = current : build_text_hierarchy levels' branches
+
+build_text_hierarchy (LastNode:others) ((GateNode label g branches):[]) = text
+  where
+    levels' = LastNode : NotVisible : others
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+    text = current : build_text_hierarchy levels' branches
+
+build_text_hierarchy (LastNode:others) ((GateNode label g branches):gs) = text ++ build_text_hierarchy (LastNode:others) gs
+  where
+    levels' = NodeHere : NotVisible : others
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+    text = current : build_text_hierarchy levels' branches
+
+build_text_hierarchy (NodeHere:others) ((GateNode label g branches):[]) = text
+  where
+    levels' = LastNode : Continues : others
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+    text = current : build_text_hierarchy levels' branches
+
+build_text_hierarchy (NodeHere:others) ((GateNode label g branches):gs) = text ++ build_text_hierarchy (NodeHere:others) gs
+  where
+    levels' = NodeHere : Continues : others
+    current = hierarchy_indent_string levels' <> (brief_gate_info g)
+    text = current : build_text_hierarchy levels' branches
+
+
+
+
+empty_region :: Region
+empty_region = Region { r_type  = RectangleRegion
+                      , r_xparam = ""
+                      , r_yparam = ""
+                      , r_points = [] }
+
+empty_gate :: DivaGate
+empty_gate = DivaGate { dg_name = ""
+                      , dg_enabled = True
+                      , dg_parent = "All Events"
+                      , dg_region = empty_region
+                      , dg_x_scaled = False
+                      , dg_y_scaled = False
+                      , dg_x_log = False
+                      , dg_y_log = False
+                      , dg_x_scale = 0.0
+                      , dg_y_scale = 0.0
+                      , dg_input = "" }
+
+
+
+
+p1_gate = empty_gate { dg_name = "P1", dg_parent = "All Events"}
+p2_gate = empty_gate { dg_name = "P2", dg_parent = "All Events\\P1"}
+p3_gate = empty_gate { dg_name = "P3", dg_parent = "All Events\\P1"}
+p4_gate = empty_gate { dg_name = "P4", dg_parent = "All Events\\P1\\P2"}
+p5_gate = empty_gate { dg_name = "P5", dg_parent = "All Events"}
+
+show_hierarchy :: [DivaGate] -> IO ()
+show_hierarchy gates = do
+  let root = build_hierarchy diva_default_root_node gates
+      lines = build_text_hierarchy [] [root]
+  mapM_ putStrLn lines
+
+