risk-weaver 0.1.0.1 → 0.1.0.2

raw patch · 12 files changed

+1880/−522 lines, 12 filesdep +asyncdep +deepseqdep +paralleldep ~JuicyPixelsdep ~containersdep ~filepathnew-component:exe:sample-riskPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, deepseq, parallel

Dependency ranges changed: JuicyPixels, containers, filepath, text, transformers, vector

API changes (from Hackage documentation)

Files

• app/Main.hs +2/−1
• bin/sample-risk.hs +596/−0
• risk-weaver.cabal +25/−2
• src/RiskWeaver/Cmd/BDD.hs +247/−156
• src/RiskWeaver/Cmd/Core.hs +67/−99
• src/RiskWeaver/DSL/BDD.hs +224/−104
• src/RiskWeaver/DSL/Core.hs +275/−29
• src/RiskWeaver/Display.hs +40/−21
• src/RiskWeaver/Draw.hs +199/−23
• src/RiskWeaver/Format/Coco.hs +117/−17
• src/RiskWeaver/Metric.hs +62/−70
• src/RiskWeaver/Pip.hs +26/−0

@@ -3,7 +3,8 @@  module Main where -import RiskWeaver.Cmd.Core qualified as Core import RiskWeaver.Cmd.BDD qualified as BDD+import RiskWeaver.Cmd.Core qualified as Core +main :: IO () main = Core.baseMain BDD.bddCommand

@@ -0,0 +1,596 @@+#!/usr/bin/env cabal+{- cabal:+build-depends: base+             , risk-weaver == 0.1.0.2+	     , containers+	     , vector+	     , text+	     , random+	     , transformers+       , parallel+       , filepath+       , JuicyPixels+-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++import Codec.Picture+import Control.Monad+import Control.Monad.Trans.Reader (ReaderT, ask, runReader)+import Control.Parallel.Strategies+import Data.List (sortBy)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics+import RiskWeaver.Cmd.Core (RiskCommands (..), baseMain)+import RiskWeaver.DSL.Core+import RiskWeaver.DSL.Core qualified as Core+import RiskWeaver.Display (putImage)+import RiskWeaver.Draw+import RiskWeaver.Format.Coco+import RiskWeaver.Metric+import RiskWeaver.Metric qualified as M+import RiskWeaver.Pip+import System.FilePath ((</>))+import Text.Printf+++++data BoundingBoxGT = BoundingBoxGT+  { x :: Double,+    y :: Double,+    w :: Double,+    h :: Double,+    cls :: Class,+    idx :: Int+  }+  deriving (Show, Eq, Ord, Generic, NFData)++data Class+  = Background+  | Pedestrian+  | Rider+  | Car+  | Truck+  | Bus+  | Train+  | Motorcycle+  | Bicycle+  deriving (Show, Eq, Ord, Generic, NFData)++data SubErrorType+  = Boundary+  | LowScore+  | MissClass+  | Occulusion+  deriving (Show, Ord, Eq, Generic, NFData)++type BoundingBoxDT = Detection BoundingBoxGT++instance Rectangle BoundingBoxGT where+  rX b = b.x+  rY b = b.y+  rW b = b.w+  rH b = b.h+  +instance Rectangle (Detection BoundingBoxGT) where+  rX b = b.x+  rY b = b.y+  rW b = b.w+  rH b = b.h+  +instance BoundingBox BoundingBoxGT where+  data Detection _ = BoundingBoxDT+    { x :: Double,+      y :: Double,+      w :: Double,+      h :: Double,+      cls :: Class,+      score :: Double,+      idx :: Int+    }+    deriving (Show, Eq, Ord, Generic, NFData)+  type ClassG _ = Class+  type ClassD _ = Class+  data ErrorType _+    = FalsePositive (Set SubErrorType)+    | FalseNegative (Set SubErrorType)+    | TruePositive+    | TrueNegative+    deriving (Ord, Eq, Generic, NFData)+  type InterestArea _ = [(Double, Double)]+  type InterestObject _ = Either BoundingBoxGT BoundingBoxDT -> Bool+  data Env _ = MyEnv+    { envGroundTruth :: Vector BoundingBoxGT,+      envDetection :: Vector BoundingBoxDT,+      envConfidenceScoreThresh :: Double,+      envIoUThresh :: Double,+      envUseInterestArea :: Bool,+      envImageId :: ImageId+    }+    deriving (Show, Ord, Eq, Generic, NFData)+  type Idx _ = Int+  type ImgIdx _ = ImageId+  data Risk _ = BddRisk+    { riskType :: ErrorType BoundingBoxGT,+      risk :: Double,+      riskGt :: Maybe BoundingBoxGT,+      riskDt :: Maybe (Detection BoundingBoxGT)+    } deriving (Show, Ord, Eq, Generic, NFData)++  interestArea :: Env BoundingBoxGT -> InterestArea BoundingBoxGT+  interestArea _ = [(0, 1), (0.3, 0.6), (0.7, 0.6), (1, 1), (1, 2), (0, 2)]+  interestObject _ = \case+    Left gt -> gt.w * gt.h > 1000+    Right dt -> dt.w * dt.h > 1000+  groundTruth env = envGroundTruth env+  detection env = envDetection env+  confidenceScoreThresh env = envConfidenceScoreThresh env+  ioUThresh env = envIoUThresh env+  scoreD v = v.score+  classD v = v.cls+  idD v = v.idx+  imageId env = envImageId env++  isBackD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isBackD _ _ = undefined++  isLeftD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isLeftD _ _ = undefined+  isRightD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isRightD _ _ = undefined+  isTopD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isTopD _ _ = undefined+  isBottomD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isBottomD _ _ = undefined+  isBackGroundD :: ClassD BoundingBoxGT -> Bool+  isBackGroundD Background = True+  isBackGroundD _ = False+  toErrorType = riskType+  toRiskScore = Main.risk++  classG v = v.cls+  angle _ _ = undefined+  idG v = v.idx++  isInIeterestAreaD :: InterestArea BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isInIeterestAreaD polygon dt = pointInPolygon (Polygon polygon) (Point (dt.x, dt.y))+  isInIeterestAreaG :: InterestArea BoundingBoxGT -> BoundingBoxGT -> Bool+  isInIeterestAreaG polygon gt = pointInPolygon (Polygon polygon) (Point (gt.x, gt.y))+  isInterestObjectD :: InterestObject BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isInterestObjectD fn dt = fn $ Right dt+  isInterestObjectG :: InterestObject BoundingBoxGT -> BoundingBoxGT -> Bool+  isInterestObjectG fn gt = fn $ Left gt++  riskForGroundTruth :: forall m. (Monad m) => ReaderT (Env BoundingBoxGT) m [Risk BoundingBoxGT]+  riskForGroundTruth = do+    env <- ask+    loopG (++) [] $ \(gt :: a) ->+      whenInterestAreaG (envUseInterestArea env) gt $ do+        let riskBias = if classG @BoundingBoxGT gt == Pedestrian then 10 else 1+        case detectG env gt of+          Just (dt :: Detection a) ->+            return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = 0.0001, riskType = TruePositive}]+          Nothing -> do+            case detectMaxIouG env gt of+              Nothing -> return [BddRisk {riskGt = Just gt, riskDt = Nothing, risk = riskBias * 30, riskType = FalseNegative []}]+              Just (dt :: Detection a) -> do+                case ( classD @BoundingBoxGT dt == classG @BoundingBoxGT gt,+                       scoreD @BoundingBoxGT dt > confidenceScoreThresh env,+                       ioU gt dt > ioUThresh env,+                       ioG gt dt > ioUThresh env+                     ) of+                  (False, False, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [MissClass, LowScore, Occulusion]}]+                  (False, False, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5, riskType = FalseNegative [MissClass, LowScore]}]+                  (False, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [MissClass, Occulusion]}]+                  (False, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2, riskType = FalseNegative [MissClass]}]+                  (True, False, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [LowScore, Occulusion]}]+                  (True, False, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5, riskType = FalseNegative [LowScore]}]+                  (True, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.1, riskType = FalseNegative [Occulusion]}]+                  (True, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.0001, riskType = TruePositive}]+                  (_, _, False, False) -> return [BddRisk {riskGt = Just gt, riskDt = Nothing, risk = riskBias * 30, riskType = FalseNegative []}]+  {-# INLINEABLE riskForGroundTruth #-}+  +  riskForDetection :: forall m. (Monad m) => ReaderT (Env BoundingBoxGT) m [Risk BoundingBoxGT]+  riskForDetection = do+    env <- ask+    loopD (++) [] $ \(dt :: Detection a) ->+      whenInterestAreaD (envUseInterestArea env) dt $ do+        let riskBias = if classD @BoundingBoxGT dt == Pedestrian then 10 else 1+        case detectD env dt of+          Just (gt :: a) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = 0.0001, riskType = TruePositive}]+          Nothing -> do+            case detectMaxIouD env dt of+              Nothing -> return [BddRisk {riskGt = Nothing, riskDt = Just dt, risk = riskBias * 5, riskType = FalsePositive []}]+              Just (gt :: a) -> do+                case ( classD @BoundingBoxGT dt == classG @BoundingBoxGT gt,+                       scoreD @BoundingBoxGT dt > confidenceScoreThresh env,+                       ioU gt dt > ioUThresh env,+                       ioG gt dt > ioUThresh env+                     ) of+                  (False, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2.1, riskType = FalsePositive [MissClass, Occulusion]}]+                  (False, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2, riskType = FalsePositive [MissClass]}]+                  (True, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.1, riskType = FalsePositive [Occulusion]}]+                  (True, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.0001, riskType = TruePositive}]+                  (_, True, False, False) -> return [BddRisk {riskGt = Nothing, riskDt = Just dt, risk = riskBias * 5, riskType = FalsePositive []}]+                  (_, False, _, _) -> return []+  {-# INLINEABLE riskForDetection #-}++instance Show (ErrorType BoundingBoxGT) where+  show (FalsePositive suberrors) = "FP: " ++ foldl (\acc suberror -> acc ++ show suberror ++ ", ") "" (Set.toList suberrors)+  show (FalseNegative suberrors) = "FN: " ++ foldl (\acc suberror -> acc ++ show suberror ++ ", ") "" (Set.toList suberrors)+  show TruePositive = "TP"+  show TrueNegative = "TN"++type BddRisk = Risk BoundingBoxGT++cocoCategoryToClass :: CocoMap -> CategoryId -> Class+cocoCategoryToClass coco categoryId =+  let cocoCategory = (cocoMapCocoCategory coco) Map.! categoryId+   in case T.unpack (cocoCategoryName cocoCategory) of+        "pedestrian" -> Pedestrian+        "rider" -> Rider+        "car" -> Car+        "truck" -> Truck+        "bus" -> Bus+        "train" -> Train+        "motorcycle" -> Motorcycle+        "bicycle" -> Bicycle+        _ -> Background++cocoResultToVector :: CocoMap -> ImageId -> (Vector BoundingBoxGT, Vector BoundingBoxDT)+cocoResultToVector coco imageId' = (groundTruth', detection')+  where+    groundTruth' =+      Vector.fromList $+        maybe+          []+          ( map+              ( \(index, CocoAnnotation {..}) ->+                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoAnnotationBbox+                   in BoundingBoxGT+                        { x = cocox,+                          y = cocoy,+                          w = cocow,+                          h = cocoh,+                          cls = cocoCategoryToClass coco cocoAnnotationCategory,+                          idx = index -- cocoAnnotationId+                        }+              )+              . zip [0 ..]+          )+          (Map.lookup imageId' (cocoMapCocoAnnotation coco))+    detection' =+      Vector.fromList $+        maybe+          []+          ( map+              ( \(index, CocoResult {..}) ->+                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoResultBbox+                   in BoundingBoxDT+                        { x = cocox,+                          y = cocoy,+                          w = cocow,+                          h = cocoh,+                          cls = cocoCategoryToClass coco cocoResultCategory,+                          score = unScore cocoResultScore,+                          idx = index+                        }+              )+              . zip [0 ..]+          )+          (Map.lookup imageId' (cocoMapCocoResult coco))++data BddContext = BddContext+  { bddContextDataset :: CocoMap,+    bddContextIouThresh :: Double,+    bddContextScoreThresh :: Double,+    bddContextUseInterestArea :: Bool+  }+  deriving (Show, Eq)++instance World BddContext BoundingBoxGT where+  mAP BddContext {..} = fst $ RiskWeaver.Metric.mAP bddContextDataset (IOU bddContextIouThresh)+  ap BddContext {..} = Map.fromList $ map (\(key, value) -> (cocoCategoryToClass bddContextDataset key, value)) $ snd $ RiskWeaver.Metric.mAP bddContextDataset (IOU bddContextIouThresh)+  mF1 BddContext {..} = fst $ RiskWeaver.Metric.mF1 bddContextDataset (IOU bddContextIouThresh) (Score bddContextScoreThresh)+  f1 BddContext {..} = Map.fromList $ map (\(key, value) -> (cocoCategoryToClass bddContextDataset key, value)) $ snd $ RiskWeaver.Metric.mF1 bddContextDataset (IOU bddContextIouThresh) (Score bddContextScoreThresh)+  confusionMatrixRecall context@BddContext {..} = sortAndGroup risks+    where+      risks :: [((Class, Class), BddRisk)]+      risks = concat $ flip map (cocoMapImageIds bddContextDataset) $ \imageId' -> map getKeyValue (runReader riskForGroundTruth (toEnv context imageId'))+      getKeyValue :: BddRisk -> ((Class, Class), BddRisk)+      getKeyValue bddRisk = ((maybe Background classG bddRisk.riskGt, maybe Background classD bddRisk.riskDt), bddRisk)+  confusionMatrixPrecision context@BddContext {..} = sortAndGroup risks+    where+      risks :: [((Class, Class), BddRisk)]+      risks = concat $ flip map (cocoMapImageIds bddContextDataset) $ \imageId' -> map getKeyValue (runReader riskForDetection (toEnv context imageId'))+      getKeyValue :: BddRisk -> ((Class, Class), BddRisk)+      getKeyValue bddRisk = ((maybe Background classD bddRisk.riskDt, maybe Background classG bddRisk.riskGt), bddRisk)++  toEnv BddContext {..} imageId' =+    let (groundTruth', detection') = cocoResultToVector bddContextDataset imageId'+     in MyEnv+          { envGroundTruth = groundTruth',+            envDetection = detection',+            envConfidenceScoreThresh = bddContextScoreThresh,+            envIoUThresh = bddContextIouThresh,+            envUseInterestArea = bddContextUseInterestArea,+            envImageId = imageId'+          }++  toImageIds BddContext {..} = cocoMapImageIds bddContextDataset+++++toBddContext :: CocoMap -> Maybe Double -> Maybe Double -> Main.BddContext+toBddContext cocoMap iouThreshold scoreThresh =+  let iouThreshold'' = case iouThreshold of+        Nothing -> 0.5+        Just iouThreshold' -> iouThreshold'+      scoreThresh'' = case scoreThresh of+        Nothing -> 0.4+        Just scoreThresh' -> scoreThresh'+      context =+        Main.BddContext+          { bddContextDataset = cocoMap,+            bddContextIouThresh = iouThreshold'',+            bddContextScoreThresh = scoreThresh'',+            bddContextUseInterestArea = False+          }+   in context++showRisk :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+showRisk cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      risks = Core.runRisk @Main.BddContext @Main.BoundingBoxGT context+  putStrLn $ printf "%-12s %-12s %s" "#ImageId" "Filename" "Risk"+  let sortedRisks = sortBy (\(_, risk1) (_, risk2) -> compare risk2 risk1) risks+  forM_ sortedRisks $ \(imageId, risk) -> do+    let cocoImage = (cocoMapCocoImage cocoMap) Map.! imageId+    putStrLn $ printf "%-12d %-12s %.3f" (unImageId imageId) (T.unpack (cocoImageFileName cocoImage)) risk++showRiskWithError :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+showRiskWithError cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      risks = Core.runRiskWithError @Main.BddContext @Main.BoundingBoxGT context :: [(ImageId, [Main.BddRisk])]+  putStrLn $ printf "%-12s %-12s %-12s %-12s" "#ImageId" "Filename" "Risk" "ErrorType"+  let sum' riskWithErrors = sum $ map (\r -> r.risk) riskWithErrors+      sortedRisks = sortBy (\(_, risk1) (_, risk2) -> compare (sum' risk2) (sum' risk1)) risks+  forM_ sortedRisks $ \(imageId, risks') -> do+    let cocoImage = (cocoMapCocoImage cocoMap) Map.! imageId+    forM_ risks' $ \bddRisk -> do+      putStrLn $ printf "%-12d %-12s %.3f %-12s" (unImageId imageId) (T.unpack (cocoImageFileName cocoImage)) bddRisk.risk (show bddRisk.riskType)+++generateRiskWeightedDataset :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO ()+generateRiskWeightedDataset cocoMap cocoOutputFile iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      imageIds = Core.generateRiskWeightedImages @Main.BddContext @Main.BoundingBoxGT context+      (newCoco, newCocoResult) = resampleCocoMapWithImageIds cocoMap imageIds+  writeCoco cocoOutputFile newCoco+  let newCocoMap = toCocoMap newCoco newCocoResult cocoOutputFile ""+  Main.evaluate newCocoMap iouThreshold scoreThresh++green :: (Int, Int, Int)+green = (0, 255, 0)++red :: (Int, Int, Int)+red = (255, 0, 0)++black :: (Int, Int, Int)+black = (0, 0, 0)++showDetectionImage :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO ()+showDetectionImage cocoMap imageFile iouThreshold scoreThreshold = do+  let imageDir = getImageDir cocoMap+      imagePath = imageDir </> imageFile+  let image' = getCocoResult cocoMap imageFile+      context = toBddContext cocoMap iouThreshold scoreThreshold+  case image' of+    Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."+    Just (image, _) -> do+      imageBin' <- readImage imagePath+      let env = Core.toEnv @Main.BddContext @Main.BoundingBoxGT context (cocoImageId image)+          riskG = runReader Core.riskForGroundTruth env+          riskD = runReader Core.riskForDetection env+      forM_ riskG $ \riskg -> do+        putStrLn $ show riskg+      forM_ riskD $ \riskd -> do+        putStrLn $ show riskd+      case imageBin' of+        Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read. : " ++ show err+        Right imageBin -> do+          let imageRGB8 = convertRGB8 imageBin+          groundTruthImage <- cloneImage imageRGB8+          detectionImage <- cloneImage imageRGB8+          forM_ riskG $ \Main.BddRisk {..} -> do+            case riskGt of+              Nothing -> return ()+              Just riskGt' -> do+                let annotation = env.envGroundTruth Vector.! (Core.idG riskGt')+                    (bx, by, bw, bh) = (annotation.x, annotation.y, annotation.w, annotation.h)+                    category = annotation.cls+                    x = round bx+                    y = round by+                    width = round bw+                    height = round bh+                    draw = do+                      let color = case riskType of+                            Main.TruePositive -> green+                            _ -> red+                      drawRect x y (x + width) (y + height) color groundTruthImage+                      drawString (show category) x y color black groundTruthImage+                      drawString (printf "%.2f" risk) x (y + 10) color black groundTruthImage+                      drawString (show riskType) x (y + 20) color black groundTruthImage+                -- Use printf format to show score+                -- drawString (printf "%.2f" (unScore $ riskGt.score)) x (y + 10) green black imageRGB8+                -- drawString (show $ cocoResultScore annotation)  x (y + 10) (255,0,0) (0,0,0) imageRGB8+                draw+          forM_ riskD $ \Main.BddRisk {..} -> do+            case riskDt of+              Nothing -> return ()+              Just riskDt' -> do+                let annotation = env.envDetection Vector.! Core.idD riskDt'+                    (bx, by, bw, bh) = (annotation.x, annotation.y, annotation.w, annotation.h)+                    category = annotation.cls+                    x = round bx+                    y = round by+                    width = round bw+                    height = round bh+                    draw = do+                      let color = case riskType of+                            Main.TruePositive -> green+                            _ -> red+                      drawRect x y (x + width) (y + height) color detectionImage+                      drawString (show category) x y color black detectionImage+                      drawString (printf "%.2f" (annotation.score)) x (y + 10) color black detectionImage+                      drawString (printf "%.2f" risk) x (y + 20) color black detectionImage+                      drawString (show riskType) x (y + 30) color black detectionImage+                if annotation.score >= context.bddContextScoreThresh+                  then draw+                  else return ()+          concatImage <- concatImageByHorizontal groundTruthImage detectionImage+          -- let resizedImage = resizeRGB8 groundTruthImage.imageWidth groundTruthImage.imageHeight True concatImage+          putImage (Right concatImage)++(!!!) :: forall a b. Ord b => Map.Map b [a] -> b -> [a]+(!!!) dat key = fromMaybe [] (Map.lookup key dat)++evaluate :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+evaluate cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      mAP = Core.mAP @Main.BddContext @Main.BoundingBoxGT context+      ap' = Core.ap @Main.BddContext @Main.BoundingBoxGT context+      f1 = Core.f1 @Main.BddContext @Main.BoundingBoxGT context+      mF1 = Core.mF1 @Main.BddContext @Main.BoundingBoxGT context+      confusionMatrixR :: Map.Map (Main.Class, Main.Class) [Main.BddRisk]+      confusionMatrixR = Core.confusionMatrixRecall @Main.BddContext @Main.BoundingBoxGT context -- Metric.confusionMatrix @(Sum Int) cocoMap iouThreshold' scoreThresh'+      confusionMatrixP :: Map.Map (Main.Class, Main.Class) [Main.BddRisk]+      confusionMatrixP = Core.confusionMatrixPrecision @Main.BddContext @Main.BoundingBoxGT context -- Metric.confusionMatrix @(Sum Int) cocoMap iouThreshold' scoreThresh'+      confusionMatrixR_cnt :: Map.Map (Main.Class, Main.Class) Int+      confusionMatrixR_cnt = Map.fromList $ concat $+        flip map (cocoMapCategoryIds cocoMap) $ \categoryId ->+          let classG = Main.cocoCategoryToClass cocoMap categoryId+              keyBG = (classG, Main.Background)+              toBG = (keyBG, length $ confusionMatrixR !!! keyBG)+              toClasses =+                flip map (cocoMapCategoryIds cocoMap) $ \categoryId' ->+                  let classD = Main.cocoCategoryToClass cocoMap categoryId'+                      keyCl = (classG, classD)+                  in (keyCl, length $ confusionMatrixR !!! keyCl)+          in toBG: toClasses+      confusionMatrixP_cnt :: Map.Map (Main.Class, Main.Class) Int+      confusionMatrixP_cnt = Map.fromList $ concat $+        flip map (cocoMapCategoryIds cocoMap) $ \categoryId ->+          let classD = Main.cocoCategoryToClass cocoMap categoryId+              keyBG = (classD, Main.Background)+              toBG = (keyBG, length $ confusionMatrixP !!! keyBG)+              toClasses =+                flip map (cocoMapCategoryIds cocoMap) $ \categoryId' ->+                  let classG = Main.cocoCategoryToClass cocoMap categoryId'+                      keyCl = (classD, classG)+                  in (keyCl, length $ confusionMatrixP !!! keyCl)+          in toBG: toClasses+        +  putStrLn $ printf "#%-12s, %s" "CocoFile" cocoMap.cocoMapCocoFile+  putStrLn $ printf "#%-12s, %s" "CocoResultFile" cocoMap.cocoMapCocoResultFile++  putStrLn $ printf "%-12s, %s" "#Category" "AP"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let class' = Main.cocoCategoryToClass cocoMap categoryId+    putStrLn $ printf "%-12s, %.3f" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId))) (ap' Map.! class')+  putStrLn $ printf "%-12s, %.3f" "mAP" mAP+  putStrLn ""++  -- Print risk scores statistically+  let risks = Core.runRisk @Main.BddContext @Main.BoundingBoxGT context+  putStrLn $ printf "%-12s" "#Risk"+  let num_of_images = (length $ map snd risks)+      max_risks = (maximum $ map snd risks)+      sorted_risks = sortBy (\r1 r2 -> compare r2 r1) $ map snd risks+      percentile_90 = take (num_of_images * 10 `div` 100) sorted_risks+  putStrLn $ printf "%-12s, %.2f" "total" (sum $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "maximum" max_risks+  putStrLn $ printf "%-12s, %.2f" "average" (M.average $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "minimum" (minimum $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "90percentile" $ head $ reverse percentile_90+  putStrLn $ printf "%-12s, %d" "num_of_images" num_of_images+  putStrLn ""++  -- Print confusion matrix+  putStrLn "#confusion matrix of recall: row is ground truth, column is prediction."+  putStr $ printf "%-12s," "#GT \\ DT"+  putStr $ printf "%-12s," "Backgroud"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+  putStrLn ""+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let classG = Main.cocoCategoryToClass cocoMap categoryId+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+    putStr $ printf "%-12d," $ confusionMatrixR_cnt Map.! (classG, Main.Background)+    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do+      let classD = Main.cocoCategoryToClass cocoMap categoryId'+      putStr $ printf "%-12d," $ confusionMatrixR_cnt Map.! (classG, classD)+    putStrLn ""+  putStrLn ""++  putStrLn "#confusion matrix of precision: row is prediction, column is ground truth."+  putStr $ printf "#%-11s," "DT \\ GT"+  putStr $ printf "%-12s," "Backgroud"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+  putStrLn ""+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let classD = Main.cocoCategoryToClass cocoMap categoryId+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+    putStr $ printf "%-12d," $ confusionMatrixP_cnt Map.! (classD, Main.Background)+    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do+      let classG = Main.cocoCategoryToClass cocoMap categoryId'+      putStr $ printf "%-12d," $ confusionMatrixP_cnt Map.! (classD, classG)+    putStrLn ""+  putStrLn ""++  -- Print F1 scores+  putStrLn "#F1 Scores"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let class' = Main.cocoCategoryToClass cocoMap categoryId+    putStrLn $ printf "%-12s, %.3f" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId))) (f1 Map.! class')+  putStrLn $ printf "%-12s, %.3f" "mF1" mF1+  putStrLn ""+  putStrLn ""++bddCommand :: RiskCommands+bddCommand =+  RiskCommands+    { showRisk = Main.showRisk,+      showRiskWithError = Main.showRiskWithError,+      generateRiskWeightedDataset = Main.generateRiskWeightedDataset,+      showDetectionImage = Main.showDetectionImage,+      evaluate = Main.evaluate+    }+main = baseMain bddCommand

@@ -8,7 +8,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0.1+version:            0.1.0.2  synopsis: A DSL for Risk-oriented Object Detection Requirements description: Please see the README on GitHub at <https://github.com/jst-qaml/risk-weaver#readme>@@ -38,6 +38,7 @@                     , RiskWeaver.Draw                     , RiskWeaver.Display                     , RiskWeaver.Metric+                    , RiskWeaver.Pip                     , RiskWeaver.Cmd.Core                     , RiskWeaver.Cmd.BDD     build-depends:    base == 4.*@@ -55,9 +56,12 @@                     , text >= 2.0.2 && < 2.1                     , transformers >= 0.6.1 && < 0.7                     , vector >= 0.13.1 && < 0.14+                    , parallel >= 3.2.1 && < 3.3+                    , deepseq >= 1.4.8 && < 1.5+                    , async >= 2.2.1 && < 2.3     hs-source-dirs:   src     default-language: GHC2021-+    default-extensions:  StrictData executable risk-weaver-exe     import:           warnings     main-is:          Main.hs@@ -65,7 +69,26 @@                     , risk-weaver     hs-source-dirs:   app     default-language: GHC2021+    ghc-options:      -rtsopts -threaded "-with-rtsopts=-A1g -N2"+    default-extensions:  StrictData +executable sample-risk+    import:           warnings+    main-is:          sample-risk.hs+    build-depends:    base == 4.*+                    , risk-weaver+                    , vector+                    , JuicyPixels+                    , text+                    , transformers+                    , containers+                    , filepath+                    , parallel+    hs-source-dirs:   bin+    default-language: GHC2021+    ghc-options:      -rtsopts -threaded "-with-rtsopts=-A1g -N2"+    default-extensions:  StrictData+        test-suite risk-weaver-test     import:           warnings

@@ -1,182 +1,273 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}  module RiskWeaver.Cmd.BDD where +import Codec.Picture import Control.Monad-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)-import RiskWeaver.DSL.BDD qualified as BDD-import Data.ByteString qualified as BS-import Data.FileEmbed (embedFile)+import Control.Monad.Trans.Reader (runReader) import Data.List (sortBy) import Data.Map qualified as Map+import Data.Maybe (fromMaybe) import Data.Text qualified as T-import Data.Vector (Vector) import Data.Vector qualified as Vector+import RiskWeaver.Cmd.Core (RiskCommands (..))+import RiskWeaver.DSL.BDD qualified as BDD+import RiskWeaver.DSL.Core qualified as Core+import RiskWeaver.Display (putImage)+import RiskWeaver.Draw+import RiskWeaver.Metric qualified as M import RiskWeaver.Format.Coco-import RiskWeaver.Metric--import Options.Applicative-import System.Random+import System.FilePath ((</>)) import Text.Printf-import RiskWeaver.Cmd.Core (RiskCommands(..)) -cocoCategoryToClass :: CocoMap -> CategoryId -> BDD.Class-cocoCategoryToClass coco categoryId =-  let cocoCategory = (cocoMapCocoCategory coco) Map.! categoryId-   in case T.unpack (cocoCategoryName cocoCategory) of-        "pedestrian" -> BDD.Pedestrian-        "rider" -> BDD.Rider-        "car" -> BDD.Car-        "truck" -> BDD.Truck-        "bus" -> BDD.Bus-        "train" -> BDD.Train-        "motorcycle" -> BDD.Motorcycle-        "bicycle" -> BDD.Bicycle-        _ -> BDD.Background--cocoResultToVector :: CocoMap -> ImageId -> (Vector BDD.BoundingBoxGT, Vector BDD.BoundingBoxDT)-cocoResultToVector coco imageId = (groundTruth, detection)-  where-    groundTruth =-      Vector.fromList $-        maybe-          []-          ( map-              ( \CocoAnnotation {..} ->-                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoAnnotationBbox-                   in BDD.BoundingBoxGT-                        { x = cocox,-                          y = cocoy,-                          w = cocow,-                          h = cocoh,-                          cls = cocoCategoryToClass coco cocoAnnotationCategory,-                          idx = cocoAnnotationId-                        }-              )-          )-          (Map.lookup imageId (cocoMapCocoAnnotation coco))-    detection =-      Vector.fromList $-        maybe-          []-          ( map-              ( \CocoResult {..} ->-                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoResultBbox-                   in BDD.BoundingBoxDT-                        { x = cocox,-                          y = cocoy,-                          w = cocow,-                          h = cocoh,-                          cls = cocoCategoryToClass coco cocoResultCategory,-                          score = unScore cocoResultScore,-                          idx = unImageId cocoResultImageId-                        }-              )-          )-          (Map.lookup imageId (cocoMapCocoResult coco))--runRisk ::-  CocoMap ->-  IO [(ImageId, Double)]-runRisk cocoMap = do-  forM (cocoMapImageIds cocoMap) $ \imageId -> do-    let (groundTruth, detection) = cocoResultToVector cocoMap imageId-    let env =-          BDD.MyEnv-            { envGroundTruth = groundTruth,-              envDetection = detection,-              envConfidenceScoreThresh = 0.4,-              envIoUThresh = 0.5-            }-    risk <- flip runReaderT env (BDD.myRisk @BDD.BoundingBoxGT)-    return (imageId, risk)+toBddContext :: CocoMap -> Maybe Double -> Maybe Double -> BDD.BddContext+toBddContext cocoMap iouThreshold scoreThresh =+  let iouThreshold'' = case iouThreshold of+        Nothing -> 0.5+        Just iouThreshold' -> iouThreshold'+      scoreThresh'' = case scoreThresh of+        Nothing -> 0.4+        Just scoreThresh' -> scoreThresh'+      context =+        BDD.BddContext+          { bddContextDataset = cocoMap,+            bddContextIouThresh = iouThreshold'',+            bddContextScoreThresh = scoreThresh'',+            bddContextUseInterestArea = False+          }+   in context -showRisk :: Coco -> [CocoResult] -> Maybe Double -> Maybe Double -> Maybe ImageId -> IO ()-showRisk coco cocoResults iouThreshold scoreThresh mImageId = do-  let cocoMap =-        let cocoMap' = toCocoMap coco cocoResults-         in case mImageId of-              Nothing -> cocoMap'-              Just imageId -> cocoMap' {cocoMapImageIds = [imageId]}-      iouThreshold' = case iouThreshold of-        Nothing -> IOU 0.5-        Just iouThreshold -> IOU iouThreshold-      scoreThresh' = case scoreThresh of-        Nothing -> Score 0.4-        Just scoreThresh -> Score scoreThresh-  risks <- runRisk cocoMap+showRisk :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+showRisk cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      risks = Core.runRisk @BDD.BddContext @BDD.BoundingBoxGT context   putStrLn $ printf "%-12s %-12s %s" "#ImageId" "Filename" "Risk"   let sortedRisks = sortBy (\(_, risk1) (_, risk2) -> compare risk2 risk1) risks   forM_ sortedRisks $ \(imageId, risk) -> do     let cocoImage = (cocoMapCocoImage cocoMap) Map.! imageId     putStrLn $ printf "%-12d %-12s %.3f" (unImageId imageId) (T.unpack (cocoImageFileName cocoImage)) risk -generateRiskWeightedDataset :: Coco -> [CocoResult] -> FilePath -> Maybe Double -> Maybe Double -> IO ()-generateRiskWeightedDataset coco cocoResults cocoOutputFile iouThreshold scoreThresh = do-  let cocoMap = toCocoMap coco cocoResults-      iouThreshold' = case iouThreshold of-        Nothing -> IOU 0.5-        Just iouThreshold -> IOU iouThreshold-      scoreThresh' = case scoreThresh of-        Nothing -> Score 0.4-        Just scoreThresh -> Score scoreThresh-  risks <- runRisk cocoMap-  let sumRisks = sum $ map snd risks-      probabilitis = map (\(_, risk) -> risk / sumRisks) risks-      accumulatedProbabilitis = scanl (+) 0 probabilitis-      numDatasets = length $ cocoMapImageIds cocoMap-      seed = mkStdGen 0+showRiskWithError :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+showRiskWithError cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      risks = Core.runRiskWithError @BDD.BddContext @BDD.BoundingBoxGT context :: [(ImageId, [BDD.BddRisk])]+  putStrLn $ printf "%-12s %-12s %-12s %-12s" "#ImageId" "Filename" "Risk" "ErrorType"+  let sum' riskWithErrors = sum $ map (\r -> r.risk) riskWithErrors+      sortedRisks = sortBy (\(_, risk1) (_, risk2) -> compare (sum' risk2) (sum' risk1)) risks+  forM_ sortedRisks $ \(imageId, risks') -> do+    let cocoImage = (cocoMapCocoImage cocoMap) Map.! imageId+    forM_ risks' $ \bddRisk -> do+      putStrLn $ printf "%-12d %-12s %.3f %-12s" (unImageId imageId) (T.unpack (cocoImageFileName cocoImage)) bddRisk.risk (show bddRisk.riskType) -  -- Generate dataset by probability.-  -- The dataset's format is same as coco dataset.-  -- Accumurate probability-  -- Gen sorted list by accumulated probability with image id.-  -- Lottery by random number-  -- Get image id by lottery-  -- Generate random number between 0 and 1-  -- Find accumulated probability that is greater than random number-  -- Get image id by accumulated probability -  -- imageSets has accumulated probability and image id.-  -- It uses binary search to find image id by random number.-  let imageSets :: Vector (Double, ImageId)-      imageSets = Vector.fromList $ zip accumulatedProbabilitis (cocoMapImageIds cocoMap)-      findImageIdFromImageSets :: Vector (Double, ImageId) -> Double -> ImageId-      findImageIdFromImageSets imageSets randomNum =-        let (start, end) = (0, Vector.length imageSets - 1)-            findImageIdFromImageSets' :: Int -> Int -> ImageId-            findImageIdFromImageSets' start end =-              let mid = (start + end) `div` 2-                  (accumulatedProbability, imageId) = imageSets Vector.! mid-               in if start == end-                    then imageId-                    else-                      if accumulatedProbability > randomNum-                        then findImageIdFromImageSets' start mid-                        else findImageIdFromImageSets' (mid + 1) end-         in findImageIdFromImageSets' start end-      lotteryN :: Int -> StdGen -> Int -> [ImageId]-      lotteryN _ _ 0 = []-      lotteryN numDatasets seed n =-        let (randNum, seed') = randomR (0, 1) seed-            imageId = findImageIdFromImageSets imageSets randNum-         in imageId : lotteryN numDatasets seed' (n - 1)-      imageIds = lotteryN numDatasets seed numDatasets-      cocoImages' = map (\imageId -> (cocoMapCocoImage cocoMap) Map.! imageId) imageIds-      newCoco =-        Coco-          { cocoImages = cocoImages',-            cocoCategories = cocoCategories coco,-            cocoAnnotations = [],-            cocoLicenses = cocoLicenses coco,-            cocoInfo = cocoInfo coco-          }+generateRiskWeightedDataset :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO ()+generateRiskWeightedDataset cocoMap cocoOutputFile iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      imageIds = Core.generateRiskWeightedImages @BDD.BddContext @BDD.BoundingBoxGT context+      (newCoco, newCocoResult) = resampleCocoMapWithImageIds cocoMap imageIds   writeCoco cocoOutputFile newCoco+  let newCocoMap = toCocoMap newCoco newCocoResult cocoOutputFile ""+  RiskWeaver.Cmd.BDD.evaluate newCocoMap iouThreshold scoreThresh +green :: (Int, Int, Int)+green = (0, 255, 0) +red :: (Int, Int, Int)+red = (255, 0, 0)++black :: (Int, Int, Int)+black = (0, 0, 0)++showDetectionImage :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO ()+showDetectionImage cocoMap imageFile iouThreshold scoreThreshold = do+  let imageDir = getImageDir cocoMap+      imagePath = imageDir </> imageFile+  let image' = getCocoResult cocoMap imageFile+      context = toBddContext cocoMap iouThreshold scoreThreshold+  case image' of+    Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."+    Just (image, _) -> do+      imageBin' <- readImage imagePath+      let env = Core.toEnv @BDD.BddContext @BDD.BoundingBoxGT context (cocoImageId image)+          riskG = runReader Core.riskForGroundTruth env+          riskD = runReader Core.riskForDetection env+      forM_ riskG $ \riskg -> do+        putStrLn $ show riskg+      forM_ riskD $ \riskd -> do+        putStrLn $ show riskd+      case imageBin' of+        Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read. : " ++ show err+        Right imageBin -> do+          let imageRGB8 = convertRGB8 imageBin+          groundTruthImage <- cloneImage imageRGB8+          detectionImage <- cloneImage imageRGB8+          forM_ riskG $ \BDD.BddRisk {..} -> do+            case riskGt of+              Nothing -> return ()+              Just riskGt' -> do+                let annotation = env.envGroundTruth Vector.! (Core.idG riskGt')+                    (bx, by, bw, bh) = (annotation.x, annotation.y, annotation.w, annotation.h)+                    category = annotation.cls+                    x = round bx+                    y = round by+                    width = round bw+                    height = round bh+                    draw = do+                      let color = case riskType of+                            BDD.TruePositive -> green+                            _ -> red+                      drawRect x y (x + width) (y + height) color groundTruthImage+                      drawString (show category) x y color black groundTruthImage+                      drawString (printf "%.2f" risk) x (y + 10) color black groundTruthImage+                      drawString (show riskType) x (y + 20) color black groundTruthImage+                -- Use printf format to show score+                -- drawString (printf "%.2f" (unScore $ riskGt.score)) x (y + 10) green black imageRGB8+                -- drawString (show $ cocoResultScore annotation)  x (y + 10) (255,0,0) (0,0,0) imageRGB8+                draw+          forM_ riskD $ \BDD.BddRisk {..} -> do+            case riskDt of+              Nothing -> return ()+              Just riskDt' -> do+                let annotation = env.envDetection Vector.! Core.idD riskDt'+                    (bx, by, bw, bh) = (annotation.x, annotation.y, annotation.w, annotation.h)+                    category = annotation.cls+                    x = round bx+                    y = round by+                    width = round bw+                    height = round bh+                    draw = do+                      let color = case riskType of+                            BDD.TruePositive -> green+                            _ -> red+                      drawRect x y (x + width) (y + height) color detectionImage+                      drawString (show category) x y color black detectionImage+                      drawString (printf "%.2f" (annotation.score)) x (y + 10) color black detectionImage+                      drawString (printf "%.2f" risk) x (y + 20) color black detectionImage+                      drawString (show riskType) x (y + 30) color black detectionImage+                if annotation.score >= context.bddContextScoreThresh+                  then draw+                  else return ()+          concatImage <- concatImageByHorizontal groundTruthImage detectionImage+          -- let resizedImage = resizeRGB8 groundTruthImage.imageWidth groundTruthImage.imageHeight True concatImage+          putImage (Right concatImage)++(!!!) :: forall a b. Ord b => Map.Map b [a] -> b -> [a]+(!!!) dat key = fromMaybe [] (Map.lookup key dat)++evaluate :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+evaluate cocoMap iouThreshold scoreThresh = do+  let context = toBddContext cocoMap iouThreshold scoreThresh+      mAP = Core.mAP @BDD.BddContext @BDD.BoundingBoxGT context+      ap' = Core.ap @BDD.BddContext @BDD.BoundingBoxGT context+      f1 = Core.f1 @BDD.BddContext @BDD.BoundingBoxGT context+      mF1 = Core.mF1 @BDD.BddContext @BDD.BoundingBoxGT context+      confusionMatrixR :: Map.Map (BDD.Class, BDD.Class) [BDD.BddRisk]+      confusionMatrixR = Core.confusionMatrixRecall @BDD.BddContext @BDD.BoundingBoxGT context -- Metric.confusionMatrix @(Sum Int) cocoMap iouThreshold' scoreThresh'+      confusionMatrixP :: Map.Map (BDD.Class, BDD.Class) [BDD.BddRisk]+      confusionMatrixP = Core.confusionMatrixPrecision @BDD.BddContext @BDD.BoundingBoxGT context -- Metric.confusionMatrix @(Sum Int) cocoMap iouThreshold' scoreThresh'+      confusionMatrixR_cnt :: Map.Map (BDD.Class, BDD.Class) Int+      confusionMatrixR_cnt = Map.fromList $ concat $+        flip map (cocoMapCategoryIds cocoMap) $ \categoryId ->+          let classG = BDD.cocoCategoryToClass cocoMap categoryId+              keyBG = (classG, BDD.Background)+              toBG = (keyBG, length $ confusionMatrixR !!! keyBG)+              toClasses =+                flip map (cocoMapCategoryIds cocoMap) $ \categoryId' ->+                  let classD = BDD.cocoCategoryToClass cocoMap categoryId'+                      keyCl = (classG, classD)+                  in (keyCl, length $ confusionMatrixR !!! keyCl)+          in toBG: toClasses+      confusionMatrixP_cnt :: Map.Map (BDD.Class, BDD.Class) Int+      confusionMatrixP_cnt = Map.fromList $ concat $+        flip map (cocoMapCategoryIds cocoMap) $ \categoryId ->+          let classD = BDD.cocoCategoryToClass cocoMap categoryId+              keyBG = (classD, BDD.Background)+              toBG = (keyBG, length $ confusionMatrixP !!! keyBG)+              toClasses =+                flip map (cocoMapCategoryIds cocoMap) $ \categoryId' ->+                  let classG = BDD.cocoCategoryToClass cocoMap categoryId'+                      keyCl = (classD, classG)+                  in (keyCl, length $ confusionMatrixP !!! keyCl)+          in toBG: toClasses+        +  putStrLn $ printf "#%-12s, %s" "CocoFile" cocoMap.cocoMapCocoFile+  putStrLn $ printf "#%-12s, %s" "CocoResultFile" cocoMap.cocoMapCocoResultFile++  putStrLn $ printf "%-12s, %s" "#Category" "AP"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let class' = BDD.cocoCategoryToClass cocoMap categoryId+    putStrLn $ printf "%-12s, %.3f" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId))) (ap' Map.! class')+  putStrLn $ printf "%-12s, %.3f" "mAP" mAP+  putStrLn ""++  -- Print risk scores statistically+  let risks = Core.runRisk @BDD.BddContext @BDD.BoundingBoxGT context+  putStrLn $ printf "%-12s" "#Risk"+  let num_of_images = (length $ map snd risks)+      max_risks = (maximum $ map snd risks)+      sorted_risks = sortBy (\r1 r2 -> compare r2 r1) $ map snd risks+      percentile_90 = take (num_of_images * 10 `div` 100) sorted_risks+  putStrLn $ printf "%-12s, %.2f" "total" (sum $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "maximum" max_risks+  putStrLn $ printf "%-12s, %.2f" "average" (M.average $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "minimum" (minimum $ map snd risks)+  putStrLn $ printf "%-12s, %.2f" "90percentile" $ head $ reverse percentile_90+  putStrLn $ printf "%-12s, %d" "num_of_images" num_of_images+  putStrLn ""++  -- Print confusion matrix+  putStrLn "#confusion matrix of recall: row is ground truth, column is prediction."+  putStr $ printf "%-12s," "#GT \\ DT"+  putStr $ printf "%-12s," "Backgroud"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+  putStrLn ""+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let classG = BDD.cocoCategoryToClass cocoMap categoryId+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+    putStr $ printf "%-12d," $ confusionMatrixR_cnt Map.! (classG, BDD.Background)+    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do+      let classD = BDD.cocoCategoryToClass cocoMap categoryId'+      putStr $ printf "%-12d," $ confusionMatrixR_cnt Map.! (classG, classD)+    putStrLn ""+  putStrLn ""++  putStrLn "#confusion matrix of precision: row is prediction, column is ground truth."+  putStr $ printf "#%-11s," "DT \\ GT"+  putStr $ printf "%-12s," "Backgroud"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+  putStrLn ""+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let classD = BDD.cocoCategoryToClass cocoMap categoryId+    putStr $ printf "%-12s," (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))+    putStr $ printf "%-12d," $ confusionMatrixP_cnt Map.! (classD, BDD.Background)+    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do+      let classG = BDD.cocoCategoryToClass cocoMap categoryId'+      putStr $ printf "%-12d," $ confusionMatrixP_cnt Map.! (classD, classG)+    putStrLn ""+  putStrLn ""++  -- Print F1 scores+  putStrLn "#F1 Scores"+  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do+    let class' = BDD.cocoCategoryToClass cocoMap categoryId+    putStrLn $ printf "%-12s, %.3f" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId))) (f1 Map.! class')+  putStrLn $ printf "%-12s, %.3f" "mF1" mF1+  putStrLn ""+  putStrLn ""+ bddCommand :: RiskCommands-bddCommand = RiskCommands {-  showRisk = RiskWeaver.Cmd.BDD.showRisk,-  generateRiskWeightedDataset = RiskWeaver.Cmd.BDD.generateRiskWeightedDataset-}+bddCommand =+  RiskCommands+    { showRisk = RiskWeaver.Cmd.BDD.showRisk,+      showRiskWithError = RiskWeaver.Cmd.BDD.showRiskWithError,+      generateRiskWeightedDataset = RiskWeaver.Cmd.BDD.generateRiskWeightedDataset,+      showDetectionImage = RiskWeaver.Cmd.BDD.showDetectionImage,+      evaluate = RiskWeaver.Cmd.BDD.evaluate+    }

@@ -1,27 +1,19 @@+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}  module RiskWeaver.Cmd.Core where  import Control.Monad-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)-import RiskWeaver.DSL.Core qualified as DSL import Data.ByteString qualified as BS import Data.FileEmbed (embedFile)-import Data.List (sortBy)-import Data.Map qualified as Map-import Data.Maybe import Data.Text qualified as T-import Data.Vector (Vector)-import Data.Vector qualified as Vector+import Options.Applicative import RiskWeaver.Display import RiskWeaver.Format.Coco-import qualified RiskWeaver.Metric as Metric-import RiskWeaver.Metric--import Options.Applicative-import System.Random-import Text.Printf+import Data.Text qualified as T+import Data.Text.Encoding qualified as T  data CocoCommand   = ListImages {cocoFile :: FilePath}@@ -37,28 +29,26 @@       { cocoFile :: FilePath,         cocoResultFile :: FilePath,         imageFile :: FilePath,+        iouThreshold :: Maybe Double,         scoreThreshold :: Maybe Double       }   | Evaluate       { cocoFile :: FilePath,         cocoResultFile :: FilePath,         iouThreshold :: Maybe Double,-        scoreThreshold :: Maybe Double,-        imageId :: Maybe Int+        scoreThreshold :: Maybe Double       }-  | ShowFalseNegative+  | ShowRisk       { cocoFile :: FilePath,         cocoResultFile :: FilePath,         iouThreshold :: Maybe Double,-        scoreThreshold :: Maybe Double,-        imageId :: Maybe Int+        scoreThreshold :: Maybe Double       }-  | ShowRisk+  | ShowRiskWithError       { cocoFile :: FilePath,         cocoResultFile :: FilePath,         iouThreshold :: Maybe Double,-        scoreThreshold :: Maybe Double,-        imageId :: Maybe Int+        scoreThreshold :: Maybe Double       }   | GenerateRiskWeightedDataset       { cocoFile :: FilePath,@@ -68,13 +58,16 @@         scoreThreshold :: Maybe Double       }   | BashCompletion+  | GenerateTemplate   deriving (Show, Eq) -data RiskCommands = -  RiskCommands-    { showRisk :: Coco -> [CocoResult] -> Maybe Double -> Maybe Double -> Maybe ImageId -> IO ()-    , generateRiskWeightedDataset :: Coco -> [CocoResult] -> FilePath -> Maybe Double -> Maybe Double -> IO ()-    }+data RiskCommands = RiskCommands+  { showRisk :: CocoMap -> Maybe Double -> Maybe Double -> IO (),+    showRiskWithError :: CocoMap -> Maybe Double -> Maybe Double -> IO (),+    generateRiskWeightedDataset :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO (),+    showDetectionImage :: CocoMap -> FilePath -> Maybe Double -> Maybe Double -> IO (),+    evaluate :: CocoMap -> Maybe Double -> Maybe Double -> IO ()+  }  listImages :: Coco -> IO () listImages coco = do@@ -124,58 +117,6 @@   forM_ cocoResults $ \cocoResult -> do     putStrLn $ show (cocoResultImageId cocoResult) ++ "\t" ++ show (cocoResultCategory cocoResult) ++ "\t" ++ show (cocoResultScore cocoResult) ++ "\t" ++ show (cocoResultBbox cocoResult) -evaluate :: Coco -> [CocoResult] -> Maybe Double -> Maybe Double -> Maybe ImageId -> IO ()-evaluate coco cocoResults iouThreshold scoreThresh mImageId = do-  -- Print mAP-  let cocoMap =-        let cocoMap' = toCocoMap coco cocoResults-         in case mImageId of-              Nothing -> cocoMap'-              Just imageId -> cocoMap' {cocoMapImageIds = [imageId]}-      iouThreshold' = case iouThreshold of-        Nothing -> IOU 0.5-        Just iouThreshold -> IOU iouThreshold-      scoreThresh' = case scoreThresh of-        Nothing -> Score 0.1-        Just scoreThresh -> Score scoreThresh-      mAP = Metric.mAP cocoMap iouThreshold'-      confusionMatrix = Metric.confusionMatrix cocoMap iouThreshold' scoreThresh'-  putStrLn $ printf "%-12s %s" "#Category" "AP"-  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do-    putStrLn $ printf "%-12s %.3f" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId))) ((Map.fromList (snd mAP)) Map.! categoryId)-  putStrLn $ printf "%-12s %.3f" "mAP" (fst mAP)-  putStrLn ""--  -- Print confusion matrix-  putStrLn "#confusion matrix of recall: row is ground truth, column is prediction."-  putStr $ printf "%-12s" "#GT \\ DT"-  putStr $ printf "%-12s" "Backgroud"-  let (!!) dat key = fromMaybe 0 (Map.lookup key dat)-      (!!!) dat key = fromMaybe Map.empty (Map.lookup key dat)-  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do-    putStr $ printf "%-12s" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))-  putStrLn ""-  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do-    putStr $ printf "%-12s" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))-    putStr $ printf "%-12d" (((confusionMatrixRecall confusionMatrix) !!! Gt categoryId) !! DtBackground)-    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do-      putStr $ printf "%-12d" (((confusionMatrixRecall confusionMatrix) !!! Gt categoryId) !! (Dt categoryId'))-    putStrLn ""-  putStrLn ""--  putStrLn "#confusion matrix of precision: row is prediction, column is ground truth."-  putStr $ printf "#%-11s" "DT \\ GT"-  putStr $ printf "%-12s" "Backgroud"-  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do-    putStr $ printf "%-12s" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))-  putStrLn ""-  forM_ (cocoMapCategoryIds cocoMap) $ \categoryId -> do-    putStr $ printf "%-12s" (T.unpack (cocoCategoryName ((cocoMapCocoCategory cocoMap) Map.! categoryId)))-    putStr $ printf "%-12d" (((confusionMatrixPrecision confusionMatrix) !!! (Dt categoryId)) !! GtBackground)-    forM_ (cocoMapCategoryIds cocoMap) $ \categoryId' -> do-      putStr $ printf "%-12d" (((confusionMatrixPrecision confusionMatrix) !!! (Dt categoryId)) !! (Gt categoryId'))-    putStrLn ""- bashCompletion :: IO () bashCompletion = do   -- Read from bash_completion.d/risk-weaver-exe and write to stdout@@ -183,6 +124,31 @@   let file = $(embedFile "bash_completion.d/risk-weaver-exe")   BS.putStr file +-- | Generate template codes to define own risk environment from BDD.+generateTemplate :: IO ()+generateTemplate = do+  -- Read from bash_completion.d/risk-weaver-exe and write to stdout+  -- Inline the file content by tepmlate haskell+  let orgDslFile = $(embedFile "src/RiskWeaver/DSL/BDD.hs")+      orgCmdFile = $(embedFile "src/RiskWeaver/Cmd/BDD.hs")+      mainLine = "main = baseMain bddCommand\n"+      mergedFile = orgDslFile <> orgCmdFile <> mainLine+      extraceLangExtFromMergedFile = -- Extract all '{-# LANGUAGE .. #-}' lines+        let langExts = T.unlines $ filter (T.isPrefixOf "{-# LANGUAGE") $ T.lines $ T.decodeUtf8 mergedFile+         in T.encodeUtf8 langExts+      extractImportLines = -- Extract all 'import ..' lines+        let importLines = T.unlines $ filter (T.isPrefixOf "import") $ T.lines $ T.decodeUtf8 mergedFile+         in T.encodeUtf8 importLines+      removeModuleAndLangExtAndImport = -- Remove module and language extension and import lines+        let removedModule = T.unlines $ filter (not . T.isPrefixOf "module") $ T.lines $ T.decodeUtf8 mergedFile+            removedLangExt = T.unlines $ filter (not . T.isPrefixOf "{-# LANGUAGE") $ T.lines removedModule+            removedImport = T.unlines $ filter (not . T.isPrefixOf "import") $ T.lines removedLangExt+         in T.encodeUtf8 removedImport+      output = -- Concat all of them(extraceLangExtFromMergedFile, extractImportLines, removeModuleAndLangExtAndImport)+        extraceLangExtFromMergedFile <> "\n" <> extractImportLines <> "\n" <> removeModuleAndLangExtAndImport+  BS.putStr output++ opts :: Parser CocoCommand opts =   subparser@@ -191,18 +157,20 @@         <> command "list-annotations" (info (ListAnnotations <$> argument str (metavar "FILE")) (progDesc "list all annotations of coco file"))         <> command "list-coco-result" (info (ListCocoResult <$> argument str (metavar "FILE")) (progDesc "list all coco result"))         <> command "show-image" (info (ShowImage <$> argument str (metavar "FILE") <*> argument str (metavar "IMAGE_FILE") <*> switch (long "enable-bounding-box" <> short 'b' <> help "enable bounding box")) (progDesc "show image by sixel"))-        <> command "show-detection-image" (info (ShowDetectionImage <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> argument str (metavar "IMAGE_FILE") <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "show detection image by sixel"))-        <> command "evaluate" (info (Evaluate <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold")) <*> optional (option auto (long "filter" <> short 'e' <> help "filter with regex"))) (progDesc "evaluate coco result"))-        <> command "show-risk" (info (ShowRisk <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold")) <*> optional (option auto (long "filter" <> short 'e' <> help "filter with regex"))) (progDesc "show risk"))+        <> command "show-detection-image" (info (ShowDetectionImage <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> argument str (metavar "IMAGE_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "show detection image by sixel"))+        <> command "evaluate" (info (Evaluate <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "evaluate coco result"))+        <> command "show-risk" (info (ShowRisk <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "show risk"))+        <> command "show-risk-with-error" (info (ShowRiskWithError <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "show risk with error"))         <> command "generate-risk-weighted-dataset" (info (GenerateRiskWeightedDataset <$> argument str (metavar "FILE") <*> argument str (metavar "RESULT_FILE") <*> argument str (metavar "OUTPUT_FILE") <*> optional (option auto (long "iou-threshold" <> short 'i' <> help "iou threshold")) <*> optional (option auto (long "score-threshold" <> short 's' <> help "score threshold"))) (progDesc "generate risk weighted dataset"))         <> command "bash-completion" (info (pure BashCompletion) (progDesc "bash completion"))+        <> command "generate-template" (info (pure GenerateTemplate) (progDesc "generate template"))     )  baseMain :: RiskCommands -> IO ()-baseMain RiskCommands{..} = do-  cmd <- customExecParser (prefs showHelpOnEmpty) (info (helper <*> opts) (fullDesc <> progDesc "coco command line tool"))+baseMain hook = do+  parsedCommand <- customExecParser (prefs showHelpOnEmpty) (info (helper <*> opts) (fullDesc <> progDesc "coco command line tool")) -  case cmd of+  case parsedCommand of     BashCompletion -> bashCompletion     ListImages cocoFile -> do       coco <- readCoco cocoFile@@ -219,19 +187,19 @@     ShowImage cocoFile imageFile enableBoundingBox -> do       coco <- readCoco cocoFile       showImage coco cocoFile imageFile enableBoundingBox-    ShowDetectionImage cocoFile cocoResultFile imageFile scoreThreshold -> do-      coco <- readCoco cocoFile-      showDetectionImage coco cocoFile cocoResultFile imageFile scoreThreshold-    Evaluate cocoFile cocoResultFile iouThreshold scoreThreshold imageId -> do-      coco <- readCoco cocoFile-      cocoResult <- readCocoResult cocoResultFile-      evaluate coco cocoResult iouThreshold scoreThreshold (fmap ImageId imageId)-    ShowRisk cocoFile cocoResultFile iouThreshold scoreThreshold imageId -> do-      coco <- readCoco cocoFile-      cocoResult <- readCocoResult cocoResultFile-      showRisk coco cocoResult iouThreshold scoreThreshold (fmap ImageId imageId)+    ShowDetectionImage cocoFile cocoResultFile imageFile iouThreshold scoreThreshold -> do+      cocoMap <- readCocoMap cocoFile cocoResultFile+      hook.showDetectionImage cocoMap imageFile iouThreshold scoreThreshold+    Evaluate cocoFile cocoResultFile iouThreshold scoreThreshold -> do+      cocoMap <- readCocoMap cocoFile cocoResultFile+      hook.evaluate cocoMap iouThreshold scoreThreshold+    ShowRisk cocoFile cocoResultFile iouThreshold scoreThreshold -> do+      cocoMap <- readCocoMap cocoFile cocoResultFile+      hook.showRisk cocoMap iouThreshold scoreThreshold+    ShowRiskWithError cocoFile cocoResultFile iouThreshold scoreThreshold -> do+      cocoMap <- readCocoMap cocoFile cocoResultFile+      hook.showRiskWithError cocoMap iouThreshold scoreThreshold     GenerateRiskWeightedDataset cocoFile cocoResultFile cocoOutputFile iouThreshold scoreThreshold -> do-      coco <- readCoco cocoFile-      cocoResult <- readCocoResult cocoResultFile-      generateRiskWeightedDataset coco cocoResult cocoOutputFile iouThreshold scoreThreshold-    _ -> return ()+      cocoMap <- readCocoMap cocoFile cocoResultFile+      hook.generateRiskWeightedDataset cocoMap cocoOutputFile iouThreshold scoreThreshold+    GenerateTemplate -> generateTemplate

@@ -1,5 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,18 +13,19 @@  module RiskWeaver.DSL.BDD where -import Control.Monad (mapM)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Reader (ReaderT, ask, runReader, runReaderT)-import RiskWeaver.DSL.Core-import Data.List qualified as List-import Data.Map (Map)-import Data.Maybe (Maybe)+import Control.Monad.Trans.Reader (ReaderT, ask, runReader)+import Control.Parallel.Strategies+import Data.Map qualified as Map import Data.Set (Set) import Data.Set qualified as Set+import Data.Text qualified as T import Data.Vector (Vector) import Data.Vector qualified as Vector+import GHC.Generics+import RiskWeaver.DSL.Core import RiskWeaver.Format.Coco+import RiskWeaver.Metric+import RiskWeaver.Pip  data BoundingBoxGT = BoundingBoxGT   { x :: Double,@@ -29,18 +35,7 @@     cls :: Class,     idx :: Int   }-  deriving (Show, Eq)--data BoundingBoxDT = BoundingBoxDT-  { x :: Double,-    y :: Double,-    w :: Double,-    h :: Double,-    cls :: Class,-    score :: Double,-    idx :: Int-  }-  deriving (Show, Eq)+  deriving (Show, Eq, Ord, Generic, NFData)  data Class   = Background@@ -52,55 +47,81 @@   | Train   | Motorcycle   | Bicycle-  deriving (Show, Eq)+  deriving (Show, Eq, Ord, Generic, NFData) -data FNError+data SubErrorType   = Boundary   | LowScore   | MissClass   | Occulusion-  deriving (Show, Eq)+  deriving (Show, Ord, Eq, Generic, NFData) +type BoundingBoxDT = Detection BoundingBoxGT++instance Rectangle BoundingBoxGT where+  rX b = b.x+  rY b = b.y+  rW b = b.w+  rH b = b.h+  +instance Rectangle (Detection BoundingBoxGT) where+  rX b = b.x+  rY b = b.y+  rW b = b.w+  rH b = b.h+   instance BoundingBox BoundingBoxGT where-  type Detection _ = BoundingBoxDT+  data Detection _ = BoundingBoxDT+    { x :: Double,+      y :: Double,+      w :: Double,+      h :: Double,+      cls :: Class,+      score :: Double,+      idx :: Int+    }+    deriving (Show, Eq, Ord, Generic, NFData)   type ClassG _ = Class   type ClassD _ = Class   data ErrorType _-    = FalsePositive-    | FalseNegative (Set FNError)+    = FalsePositive (Set SubErrorType)+    | FalseNegative (Set SubErrorType)     | TruePositive     | TrueNegative-    deriving (Show, Eq)+    deriving (Ord, Eq, Generic, NFData)   type InterestArea _ = [(Double, Double)]-  type InterestObject _ = BoundingBoxGT+  type InterestObject _ = Either BoundingBoxGT BoundingBoxDT -> Bool   data Env _ = MyEnv     { envGroundTruth :: Vector BoundingBoxGT,       envDetection :: Vector BoundingBoxDT,       envConfidenceScoreThresh :: Double,-      envIoUThresh :: Double+      envIoUThresh :: Double,+      envUseInterestArea :: Bool,+      envImageId :: ImageId     }+    deriving (Show, Ord, Eq, Generic, NFData)   type Idx _ = Int-  type Risk _ = Double+  type ImgIdx _ = ImageId+  data Risk _ = BddRisk+    { riskType :: ErrorType BoundingBoxGT,+      risk :: Double,+      riskGt :: Maybe BoundingBoxGT,+      riskDt :: Maybe (Detection BoundingBoxGT)+    } deriving (Show, Ord, Eq, Generic, NFData) -  riskE env = runReader (myRisk @BoundingBoxGT) env   interestArea :: Env BoundingBoxGT -> InterestArea BoundingBoxGT   interestArea _ = [(0, 1), (0.3, 0.6), (0.7, 0.6), (1, 1), (1, 2), (0, 2)]-  interestObject _ = undefined+  interestObject _ = \case+    Left gt -> gt.w * gt.h > 1000+    Right dt -> dt.w * dt.h > 1000   groundTruth env = envGroundTruth env   detection env = envDetection env   confidenceScoreThresh env = envConfidenceScoreThresh env   ioUThresh env = envIoUThresh env   scoreD v = v.score-  sizeD v = v.w * v.h   classD v = v.cls   idD v = v.idx--  isFrontD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool-  isFrontD dtBack dtFront =-    let intersection =-          (min (dtBack.x + dtBack.w) (dtFront.x + dtFront.w) - max dtBack.x dtFront.x)-            * (min (dtBack.y + dtBack.h) (dtFront.y + dtFront.h) - max dtBack.y dtFront.y)-     in (intersection / (dtFront.w * dtFront.h)) >= 0.99+  imageId env = envImageId env    isBackD :: Detection BoundingBoxGT -> Detection BoundingBoxGT -> Bool   isBackD _ _ = undefined@@ -116,78 +137,177 @@   isBackGroundD :: ClassD BoundingBoxGT -> Bool   isBackGroundD Background = True   isBackGroundD _ = False-  detectD :: Env BoundingBoxGT -> Detection BoundingBoxGT -> Maybe BoundingBoxGT-  detectD _ _ = undefined-  errorType :: Env BoundingBoxGT -> Detection BoundingBoxGT -> Maybe (ErrorType BoundingBoxGT)-  errorType _ _ = undefined+  toErrorType = riskType+  toRiskScore = RiskWeaver.DSL.BDD.risk -  sizeG v = v.w * v.h   classG v = v.cls   angle _ _ = undefined   idG v = v.idx-  ioU g d =-    let intersection =-          (min (g.x + g.w) (d.x + d.w) - max g.x d.x)-            * (min (g.y + g.h) (d.y + d.h) - max g.y d.y)-     in intersection / (g.w * g.h + d.w * d.h - intersection)-  ioG g d =-    let intersection =-          (min (g.x + g.w) (d.x + d.w) - max g.x d.x)-            * (min (g.y + g.h) (d.y + d.h) - max g.y d.y)-     in intersection / (g.w * g.h)-  ioD g d =-    let intersection =-          (min (g.x + g.w) (d.x + d.w) - max g.x d.x)-            * (min (g.y + g.h) (d.y + d.h) - max g.y d.y)-     in intersection / (d.w * d.h)-  detectG :: Env BoundingBoxGT -> BoundingBoxGT -> Maybe (Detection BoundingBoxGT)-  detectG env gt =-    let dts = detection env-        dts' = filter (\dt -> scoreD @BoundingBoxGT dt > confidenceScoreThresh env) $ Vector.toList dts-        dts'' = filter (\dt -> classD @BoundingBoxGT dt == classG @BoundingBoxGT gt) dts'-        -- Get max IOU detection with ioUThresh-        dts''' = filter (\(iou, _) -> iou > ioUThresh env) $ map (\dt -> (ioU gt dt, dt)) dts''-     in case dts''' of-          [] -> Nothing-          dts -> Just $ snd $ List.maximumBy (\(iou1, _) (iou2, _) -> compare iou1 iou2) dts    isInIeterestAreaD :: InterestArea BoundingBoxGT -> Detection BoundingBoxGT -> Bool-  isInIeterestAreaD _ _ = undefined-  isInIeterestAreaG _ _ = undefined+  isInIeterestAreaD polygon dt = pointInPolygon (Polygon polygon) (Point (dt.x, dt.y))+  isInIeterestAreaG :: InterestArea BoundingBoxGT -> BoundingBoxGT -> Bool+  isInIeterestAreaG polygon gt = pointInPolygon (Polygon polygon) (Point (gt.x, gt.y))+  isInterestObjectD :: InterestObject BoundingBoxGT -> Detection BoundingBoxGT -> Bool+  isInterestObjectD fn dt = fn $ Right dt+  isInterestObjectG :: InterestObject BoundingBoxGT -> BoundingBoxGT -> Bool+  isInterestObjectG fn gt = fn $ Left gt -  riskD _ _ = undefined-  riskBB _ = undefined+  riskForGroundTruth :: forall m. (Monad m) => ReaderT (Env BoundingBoxGT) m [Risk BoundingBoxGT]+  riskForGroundTruth = do+    env <- ask+    loopG (++) [] $ \(gt :: a) ->+      whenInterestAreaG (envUseInterestArea env) gt $ do+        let riskBias = if classG @BoundingBoxGT gt == Pedestrian then 10 else 1+        case detectG env gt of+          Just (dt :: Detection a) ->+            return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = 0.0001, riskType = TruePositive}]+          Nothing -> do+            case detectMaxIouG env gt of+              Nothing -> return [BddRisk {riskGt = Just gt, riskDt = Nothing, risk = riskBias * 30, riskType = FalseNegative []}]+              Just (dt :: Detection a) -> do+                case ( classD @BoundingBoxGT dt == classG @BoundingBoxGT gt,+                       scoreD @BoundingBoxGT dt > confidenceScoreThresh env,+                       ioU gt dt > ioUThresh env,+                       ioG gt dt > ioUThresh env+                     ) of+                  (False, False, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [MissClass, LowScore, Occulusion]}]+                  (False, False, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5, riskType = FalseNegative [MissClass, LowScore]}]+                  (False, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [MissClass, Occulusion]}]+                  (False, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2, riskType = FalseNegative [MissClass]}]+                  (True, False, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5.1, riskType = FalseNegative [LowScore, Occulusion]}]+                  (True, False, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 5, riskType = FalseNegative [LowScore]}]+                  (True, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.1, riskType = FalseNegative [Occulusion]}]+                  (True, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.0001, riskType = TruePositive}]+                  (_, _, False, False) -> return [BddRisk {riskGt = Just gt, riskDt = Nothing, risk = riskBias * 30, riskType = FalseNegative []}]+  {-# INLINEABLE riskForGroundTruth #-}+  +  riskForDetection :: forall m. (Monad m) => ReaderT (Env BoundingBoxGT) m [Risk BoundingBoxGT]+  riskForDetection = do+    env <- ask+    loopD (++) [] $ \(dt :: Detection a) ->+      whenInterestAreaD (envUseInterestArea env) dt $ do+        let riskBias = if classD @BoundingBoxGT dt == Pedestrian then 10 else 1+        case detectD env dt of+          Just (gt :: a) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = 0.0001, riskType = TruePositive}]+          Nothing -> do+            case detectMaxIouD env dt of+              Nothing -> return [BddRisk {riskGt = Nothing, riskDt = Just dt, risk = riskBias * 5, riskType = FalsePositive []}]+              Just (gt :: a) -> do+                case ( classD @BoundingBoxGT dt == classG @BoundingBoxGT gt,+                       scoreD @BoundingBoxGT dt > confidenceScoreThresh env,+                       ioU gt dt > ioUThresh env,+                       ioG gt dt > ioUThresh env+                     ) of+                  (False, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2.1, riskType = FalsePositive [MissClass, Occulusion]}]+                  (False, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 2, riskType = FalsePositive [MissClass]}]+                  (True, True, False, True) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.1, riskType = FalsePositive [Occulusion]}]+                  (True, True, True, _) -> return [BddRisk {riskGt = Just gt, riskDt = Just dt, risk = riskBias * 0.0001, riskType = TruePositive}]+                  (_, True, False, False) -> return [BddRisk {riskGt = Nothing, riskDt = Just dt, risk = riskBias * 5, riskType = FalsePositive []}]+                  (_, False, _, _) -> return []+  {-# INLINEABLE riskForDetection #-} -  confusionMatrixRecallBB _ = undefined-  confusionMatrixAccuracyBB _ = undefined-  confusionMatrixRecallBB' _ = undefined-  confusionMatrixAccuracyBB' _ = undefined-  errorGroupsBB _ = undefined+instance Show (ErrorType BoundingBoxGT) where+  show (FalsePositive suberrors) = "FP: " ++ foldl (\acc suberror -> acc ++ show suberror ++ ", ") "" (Set.toList suberrors)+  show (FalseNegative suberrors) = "FN: " ++ foldl (\acc suberror -> acc ++ show suberror ++ ", ") "" (Set.toList suberrors)+  show TruePositive = "TP"+  show TrueNegative = "TN" -myRisk :: forall a m. (Fractional (Risk a), Num (Risk a), BoundingBox a, Monad m) => ReaderT (Env a) m (Risk a)-myRisk = do-  env <- ask-  loopG (+) 0 $ \(gt :: a) ->-    case detectG env gt of-      Nothing -> return 10-      Just (obj :: Detection a) -> do-        if ioU gt obj > ioUThresh env-          then return 0.001-          else-            if ioG gt obj > ioUThresh env-              then return 1-              else return 5+type BddRisk = Risk BoundingBoxGT -myRiskWithError :: forall a m. (Monoid [(Risk a, ErrorType a)], BoundingBox a, Monad m, a ~ BoundingBoxGT) => ReaderT (Env a) m [(Risk a, ErrorType a)]-myRiskWithError = do-  env <- ask-  loopG (++) [] $ \(gt :: a) ->-    case detectG env gt of-      Nothing -> return [(10, FalseNegative Set.empty)]-      Just (obj :: Detection a) -> do-        if ioU gt obj > ioUThresh env-          then return [(0, TruePositive)]-          else-            if ioG gt obj > ioUThresh env-              then return [(1, FalseNegative Set.empty)]-              else return [(5, FalseNegative Set.empty)]+cocoCategoryToClass :: CocoMap -> CategoryId -> Class+cocoCategoryToClass coco categoryId =+  let cocoCategory = (cocoMapCocoCategory coco) Map.! categoryId+   in case T.unpack (cocoCategoryName cocoCategory) of+        "pedestrian" -> Pedestrian+        "rider" -> Rider+        "car" -> Car+        "truck" -> Truck+        "bus" -> Bus+        "train" -> Train+        "motorcycle" -> Motorcycle+        "bicycle" -> Bicycle+        _ -> Background++cocoResultToVector :: CocoMap -> ImageId -> (Vector BoundingBoxGT, Vector BoundingBoxDT)+cocoResultToVector coco imageId' = (groundTruth', detection')+  where+    groundTruth' =+      Vector.fromList $+        maybe+          []+          ( map+              ( \(index, CocoAnnotation {..}) ->+                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoAnnotationBbox+                   in BoundingBoxGT+                        { x = cocox,+                          y = cocoy,+                          w = cocow,+                          h = cocoh,+                          cls = cocoCategoryToClass coco cocoAnnotationCategory,+                          idx = index -- cocoAnnotationId+                        }+              )+              . zip [0 ..]+          )+          (Map.lookup imageId' (cocoMapCocoAnnotation coco))+    detection' =+      Vector.fromList $+        maybe+          []+          ( map+              ( \(index, CocoResult {..}) ->+                  let CoCoBoundingBox (cocox, cocoy, cocow, cocoh) = cocoResultBbox+                   in BoundingBoxDT+                        { x = cocox,+                          y = cocoy,+                          w = cocow,+                          h = cocoh,+                          cls = cocoCategoryToClass coco cocoResultCategory,+                          score = unScore cocoResultScore,+                          idx = index+                        }+              )+              . zip [0 ..]+          )+          (Map.lookup imageId' (cocoMapCocoResult coco))++data BddContext = BddContext+  { bddContextDataset :: CocoMap,+    bddContextIouThresh :: Double,+    bddContextScoreThresh :: Double,+    bddContextUseInterestArea :: Bool+  }+  deriving (Show, Eq)++instance World BddContext BoundingBoxGT where+  mAP BddContext {..} = fst $ RiskWeaver.Metric.mAP bddContextDataset (IOU bddContextIouThresh)+  ap BddContext {..} = Map.fromList $ map (\(key, value) -> (cocoCategoryToClass bddContextDataset key, value)) $ snd $ RiskWeaver.Metric.mAP bddContextDataset (IOU bddContextIouThresh)+  mF1 BddContext {..} = fst $ RiskWeaver.Metric.mF1 bddContextDataset (IOU bddContextIouThresh) (Score bddContextScoreThresh)+  f1 BddContext {..} = Map.fromList $ map (\(key, value) -> (cocoCategoryToClass bddContextDataset key, value)) $ snd $ RiskWeaver.Metric.mF1 bddContextDataset (IOU bddContextIouThresh) (Score bddContextScoreThresh)+  confusionMatrixRecall context@BddContext {..} = sortAndGroup risks+    where+      risks :: [((Class, Class), BddRisk)]+      risks = concat $ flip map (cocoMapImageIds bddContextDataset) $ \imageId' -> map getKeyValue (runReader riskForGroundTruth (toEnv context imageId'))+      getKeyValue :: BddRisk -> ((Class, Class), BddRisk)+      getKeyValue bddRisk = ((maybe Background classG bddRisk.riskGt, maybe Background classD bddRisk.riskDt), bddRisk)+  confusionMatrixPrecision context@BddContext {..} = sortAndGroup risks+    where+      risks :: [((Class, Class), BddRisk)]+      risks = concat $ flip map (cocoMapImageIds bddContextDataset) $ \imageId' -> map getKeyValue (runReader riskForDetection (toEnv context imageId'))+      getKeyValue :: BddRisk -> ((Class, Class), BddRisk)+      getKeyValue bddRisk = ((maybe Background classD bddRisk.riskDt, maybe Background classG bddRisk.riskGt), bddRisk)++  toEnv BddContext {..} imageId' =+    let (groundTruth', detection') = cocoResultToVector bddContextDataset imageId'+     in MyEnv+          { envGroundTruth = groundTruth',+            envDetection = detection',+            envConfidenceScoreThresh = bddContextScoreThresh,+            envIoUThresh = bddContextIouThresh,+            envUseInterestArea = bddContextUseInterestArea,+            envImageId = imageId'+          }++  toImageIds BddContext {..} = cocoMapImageIds bddContextDataset+

@@ -1,91 +1,337 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DefaultSignatures #-}  module RiskWeaver.DSL.Core where -import Control.Monad.Trans.Reader (ReaderT, ask)+import Control.Monad.Trans.Reader (ReaderT, ask, runReader)+import Control.Parallel.Strategies import Data.Kind (Type) import Data.Map (Map) import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.List qualified as List -class BoundingBox a where-  type Detection a :: Type+class Rectangle a where+  rX :: a -> Double+  rY :: a -> Double+  rW :: a -> Double+  rH :: a -> Double++-- | Bounding box type class of ground truth+class (Eq (ClassG a), Eq (ClassD a)) => BoundingBox a where+  -- | Detection type+  data Detection a :: Type++  -- | Ground truth class type   type ClassG a :: Type++  -- | Detection class type   type ClassD a :: Type++  -- | Error type   data ErrorType a :: Type++  -- | Interest area type   type InterestArea a :: Type++  -- | Interest object type   type InterestObject a :: Type++  -- | Environment type of the image   data Env a :: Type++  -- | Index type of bounding box annotations   type Idx a :: Type-  type Risk a :: Type -  riskE :: Env a -> Risk a+  -- | Image index type of bounding box annotations+  type ImgIdx a :: Type++  -- | Risk type+  data Risk a :: Type++  -- | Risk of the environment+  riskE :: Env a -> [Risk a]+  riskE env = runReader myRisk env+    where+      myRisk = do+        !riskG <- riskForGroundTruth+        !riskD <- riskForDetection+        return $ riskG <> riskD++  -- | Risk of groundtruth+  riskForGroundTruth :: Monad m => ReaderT (Env a) m [Risk a]++  -- | Risk of detection+  riskForDetection :: Monad m => ReaderT (Env a) m [Risk a]++  -- | Interest area of the environment   interestArea :: Env a -> InterestArea a++  -- | Interest object of the environment   interestObject :: Env a -> InterestObject a++  -- | Ground truth of the environment   groundTruth :: Env a -> Vector a++  -- | Detection of the environment   detection :: Env a -> Vector (Detection a)++  -- | Confidence score threshold   confidenceScoreThresh :: Env a -> Double++  -- | IoU threshold   ioUThresh :: Env a -> Double++  -- | Confidence score of the detection   scoreD :: Detection a -> Double++  -- | Size of the detection   sizeD :: Detection a -> Double+  default sizeD :: (Rectangle (Detection a)) => Detection a -> Double+  sizeD v = rW v * rH v++  -- | Class of the detection   classD :: Detection a -> ClassG a++  -- | Index of the detection   idD :: Detection a -> Idx a +  -- | Index of the image+  imageId :: Env a -> ImgIdx a++  -- | True if the detection is in front of the other detection   isFrontD :: Detection a -> Detection a -> Bool+  default isFrontD :: (Rectangle (Detection a)) => Detection a -> Detection a -> Bool+  isFrontD dtBack dtFront =+    let intersection =+          (min (rX dtBack + rW dtBack) (rX dtFront + rW dtFront) - max (rX dtBack) (rX dtFront))+            * (min (rY dtBack + rH dtBack) (rY dtFront + rH dtFront) - max (rY dtBack) (rY dtFront))+     in (intersection / (rW dtFront * rH dtFront)) >= 0.99++  -- | True if the detection is in back of the other detection   isBackD :: Detection a -> Detection a -> Bool++  -- | True if the detection is in left of the other detection   isLeftD :: Detection a -> Detection a -> Bool++  -- | True if the detection is in right of the other detection   isRightD :: Detection a -> Detection a -> Bool++  -- | True if the detection is in top of the other detection   isTopD :: Detection a -> Detection a -> Bool++  -- | True if the detection is in bottom of the other detection   isBottomD :: Detection a -> Detection a -> Bool++  -- | True if the detection is background   isBackGroundD :: ClassD a -> Bool++  -- | Detect the ground truth of the detection   detectD :: Env a -> Detection a -> Maybe a-  errorType :: Env a -> Detection a -> Maybe (ErrorType a)+  detectD env dt =+    let gts = groundTruth env+        gts'' = filter (\gt -> classD @a dt == classG @a gt) $ Vector.toList gts+        -- Get max IOU detection with ioUThresh+        gts''' = filter (\(iou', _) -> iou' > ioUThresh env) $ map (\gt -> (ioU gt dt, gt)) gts''+     in case gts''' of+          [] -> Nothing+          gts_ -> Just $ snd $ List.maximumBy (\(iou1, _) (iou2, _) -> compare iou1 iou2) gts_ +  -- | Get error type from risk+  toErrorType :: Risk a -> ErrorType a++  -- | Get a score from risk+  toRiskScore :: Risk a -> Double++  -- | Size of the ground truth   sizeG :: a -> Double+  default sizeG :: (Rectangle a) => a -> Double+  sizeG v = rW v * rH v++  -- | Class of the ground truth   classG :: a -> ClassG a++  -- | Angle of detection to the ground truth   angle :: a -> Detection a -> Double++  -- | Index of the ground truth   idG :: a -> Idx a++  -- | IoU(Intersection Over Union) of the ground truth and the detection   ioU :: a -> Detection a -> Double+  default ioU :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double+  ioU g d =+    let intersection =+          (min (rX g + rW g) (rX d + rW d) - max (rX g) (rX d))+            * (min (rY g + rH g) (rY d + rH d) - max (rY g) (rY d))+     in intersection / (rW g * rH g + rW d * rH d - intersection)++  -- | IoG(Intersection Over Ground truth) of the ground truth and the detection   ioG :: a -> Detection a -> Double+  default ioG :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double+  ioG g d =+    let intersection =+          (min (rX g + rW g) (rX d + rW d) - max (rX g) (rX d))+            * (min (rY g + rH g) (rY d + rH d) - max (rY g) (rY d))+     in intersection / (rW g * rH g)++  -- | IoD(Intersection Over Detection) of the ground truth and the detection   ioD :: a -> Detection a -> Double+  default ioD :: (Rectangle a, Rectangle (Detection a)) => a -> Detection a -> Double+  ioD g d =+    let intersection =+          (min (rX g + rW g) (rX d + rW d) - max (rX g) (rX d))+            * (min (rY g + rH g) (rY d + rH d) - max (rY g) (rY d))+     in intersection / (rW d * rH d)++  -- | Detect the detection of the ground truth   detectG :: Env a -> a -> Maybe (Detection a)+  detectG env gt =+    let dts = detection env+        dts' = filter (\dt -> scoreD @a dt > confidenceScoreThresh env) $ Vector.toList dts+        dts'' = filter (\dt -> classD @a dt == classG @a gt) dts'+        -- Get max IOU detection with ioUThresh+        dts''' = filter (\(iou', _) -> iou' > ioUThresh env) $ map (\dt -> (ioU gt dt, dt)) dts''+     in case dts''' of+          [] -> Nothing+          dts_ -> Just $ snd $ List.maximumBy (\(iou1, _) (iou2, _) -> compare iou1 iou2) dts_ +  -- | True if the detection is in the interest area   isInIeterestAreaD :: InterestArea a -> Detection a -> Bool++  -- | True if the ground truth is in the interest area   isInIeterestAreaG :: InterestArea a -> a -> Bool -  riskD :: Env a -> Detection a -> Risk a-  riskBB :: Env a -> Risk a+  -- | True if the detection is in the interest object+  isInterestObjectD :: InterestObject a -> Detection a -> Bool -  confusionMatrixRecallBB :: Env a -> Map (ClassG a, ClassD a) Double-  confusionMatrixAccuracyBB :: Env a -> Map (ClassD a, ClassG a) Double-  confusionMatrixRecallBB' :: Env a -> Map (ClassG a, ClassD a) [Idx a]-  confusionMatrixAccuracyBB' :: Env a -> Map (ClassD a, ClassG a) [Idx a]-  errorGroupsBB :: Env a -> Map (ClassG a) (Map (ErrorType a) [Idx a])+  -- | True if the ground truth is in the interest object+  isInterestObjectG :: InterestObject a -> a -> Bool -class (BoundingBox a) => World a where-  type Image a :: Type-  idI :: Image a -> Int-  env :: Image a -> Env a-  mAP :: Vector (Image a) -> Double-  ap :: Vector (Image a) -> Map (ClassG a) Double-  risk :: Vector (Image a) -> Double-  confusionMatrixRecall :: Vector (Image a) -> Map (ClassG a, ClassD a) Double-  confusionMatrixAccuracy :: Vector (Image a) -> Map (ClassD a, ClassG a) Double-  confusionMatrixRecall' :: Vector (Image a) -> Map (ClassG a, ClassD a) [Idx a]-  confusionMatrixAccuracy' :: Vector (Image a) -> Map (ClassD a, ClassG a) [Idx a]-  errorGroups :: Vector (Image a) -> Map (ClassG a) (Map (ErrorType a) [Idx a])+-- | b includes ground-truth images and detection images.+class (NFData (ImgIdx a), NFData (Risk a), BoundingBox a) => World b a where+  -- | Environments of the image+  envs :: b -> [Env a]+  envs context =+    map+      (\imageId' -> toEnv @b @a context imageId')+      (toImageIds @b @a context) +  -- | An environment of the image+  toEnv :: b -> ImgIdx a -> Env a++  -- | An environment of the image+  toImageIds :: b -> [ImgIdx a]++  -- | mAP of the images+  mAP :: b -> Double++  -- | AP of the images for each class+  ap :: b -> Map (ClassG a) Double++  -- | mF1 of the images+  mF1 :: b -> Double++  -- | F1 of the images for each class+  f1 :: b -> Map (ClassG a) Double++  -- | Risk of the images+  risk :: b -> [Risk a]+  risk context = concat $ map snd $ runRiskWithError context++  -- | Confusion matrix of recall+  confusionMatrixRecall :: b -> Map (ClassG a, ClassD a) [Risk a]++  -- | Confusion matrix of precision+  confusionMatrixPrecision :: b -> Map (ClassD a, ClassG a) [Risk a]++-- | Loop for ground truth loopG :: forall a m b. (BoundingBox a, Monad m) => (b -> b -> b) -> b -> (a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b-loopG add init fn = do+loopG add init' fn = do   env <- ask-  foldl add init <$> mapM fn (groundTruth @a env)+  foldl add init' <$> mapM fn (groundTruth @a env)+{-# INLINEABLE loopG #-} +-- | Loop for detection loopD :: forall a m b. (BoundingBox a, Monad m) => (b -> b -> b) -> b -> (Detection a -> ReaderT (Env a) m b) -> ReaderT (Env a) m b-loopD add init fn = do+loopD add init' fn = do   env <- ask-  foldl add init <$> mapM fn (detection @a env)+  foldl add init' <$> mapM fn (detection @a env)+{-# INLINEABLE loopD #-}++detectMaxIouG :: BoundingBox a => Env a -> a -> Maybe (Detection a)+detectMaxIouG env gt =+  let dts = detection env+      dts' = map (\dt -> (ioU gt dt, dt)) $ Vector.toList dts+   in case dts' of+        [] -> Nothing+        dts_ -> Just $ snd $ List.maximumBy (\(iou1, _) (iou2, _) -> compare iou1 iou2) dts_++detectMaxIouD :: BoundingBox a => Env a -> (Detection a) -> Maybe a+detectMaxIouD env dt =+  let gts = groundTruth env+      gts' = map (\gt -> (ioU gt dt, gt)) $ Vector.toList gts+   in case gts' of+        [] -> Nothing+        gts_ -> Just $ snd $ List.maximumBy (\(iou1, _) (iou2, _) -> compare iou1 iou2) gts_++whenInterestAreaD :: forall m a b. (Monad m, BoundingBox a) => Bool -> Detection a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]+whenInterestAreaD cond dt func = do+  env <- ask+  if cond+  then do+    if isInIeterestAreaD (interestArea env) dt && isInterestObjectD (interestObject env) dt+      then func+      else return []+  else func++whenInterestAreaG :: forall m a b. (Monad m, BoundingBox a) => Bool -> a -> ReaderT (Env a) m [b] -> ReaderT (Env a) m [b]+whenInterestAreaG cond gt func = do+  env <- ask+  if cond+  then do+    if isInIeterestAreaG (interestArea env) gt && isInterestObjectG (interestObject env) gt+      then func+      else return []+  else func++runRisk :: forall context a. (World context a) => context -> [(ImgIdx a, Double)]+runRisk context =+  map (\(imageId', risks) -> (imageId', sum $ map (\r -> toRiskScore r) risks)) (runRiskWithError @context @a context)+    `using` parList rdeepseq++runRiskWithError :: forall context a. (World context a) => context -> [(ImgIdx a, [Risk a])]+runRiskWithError context =+  map (\imageId' -> (imageId', riskE (toEnv context imageId'))) (toImageIds @context @a context)+    `using` parList rdeepseq++generateRiskWeightedImages :: forall b a. World b a => b -> [ImgIdx a]+generateRiskWeightedImages context =+  let risks = runRisk @b @a context+      sumRisks = sum $ map snd risks+      probs = map (\(_, risk') -> risk' / sumRisks) risks+      acc_probs =+        let loop [] _ = []+            loop (x : xs) s = (s, s + x) : loop xs (s + x)+         in loop probs 0+      numDatasets = length $ toImageIds @b @a context+      imageSets :: [((Double, Double), ImgIdx a)]+      imageSets = zip acc_probs $ map fst risks+      resample [] _ _ = []+      resample s@(((x, y), img) : xs) n end =+        if n == end+          then []+          else+            let p = (fromIntegral n :: Double) / (fromIntegral numDatasets :: Double)+             in if x <= p && p < y+                  then img : resample s (n + 1) end+                  else resample xs n end+  in resample imageSets 0 numDatasets+

@@ -19,8 +19,8 @@     Left imagePath -> do       imageBin <- readImage imagePath       case imageBin of-        Left err -> fail $ "Image file " ++ imagePath ++ " can not be read."-        Right imageBin -> return (convertRGB8 imageBin)+        Left err -> fail $ "Image file " ++ imagePath ++ " can not be read. : " ++ show err+        Right imageBin' -> return (convertRGB8 imageBin')     Right image -> return image   case termProgram of     Just "iTerm.app" -> do@@ -46,10 +46,28 @@     drawString (T.unpack (cocoCategoryName (categories Map.! cocoAnnotationCategory annotation))) x y (255, 0, 0) (0, 0, 0) imageRGB8   return imageRGB8 -drawDetectionBoundingBox :: DynamicImage -> [CocoResult] -> Map.Map CategoryId CocoCategory -> Maybe Double -> IO (Image PixelRGB8)-drawDetectionBoundingBox imageBin annotations categories scoreThreshold = do+drawDetectionBoundingBox ::+  (Show a) =>+  -- | Image+  DynamicImage ->+  -- | A list of Coco result+  [CocoResult] ->+  -- | A list of object property+  [a] ->+  -- | A map of category+  Map.Map CategoryId CocoCategory ->+  -- | Score threshold+  Maybe Double ->+  -- | Overlay function to draw object property+  Maybe (Image PixelRGB8 -> a -> IO (Image PixelRGB8)) ->+  IO (Image PixelRGB8)+drawDetectionBoundingBox imageBin annotations properties categories scoreThreshold overlay = do   let imageRGB8 = convertRGB8 imageBin-  forM_ annotations $ \annotation -> do+      zipedAnnotations = zip annotations $+        case properties of+          [] -> repeat Nothing+          _ -> map Just properties+  forM_ zipedAnnotations $ \(annotation, property) -> do     let (CoCoBoundingBox (bx, by, bw, bh)) = cocoResultBbox annotation         x = round bx         y = round by@@ -60,11 +78,16 @@           drawString (T.unpack (cocoCategoryName (categories Map.! cocoResultCategory annotation))) x y (255, 0, 0) (0, 0, 0) imageRGB8           -- Use printf format to show score           drawString (printf "%.2f" (unScore $ cocoResultScore annotation)) x (y + 10) (255, 0, 0) (0, 0, 0) imageRGB8+          case (property, overlay) of+            (Just property', Just overlay') -> do+              _ <- overlay' imageRGB8 property'+              return ()+            _ -> return ()     -- drawString (show $ cocoResultScore annotation)  x (y + 10) (255,0,0) (0,0,0) imageRGB8     case scoreThreshold of       Nothing -> draw-      Just scoreThreshold -> do-        if cocoResultScore annotation >= Score scoreThreshold+      Just scoreThreshold' -> do+        if cocoResultScore annotation >= Score scoreThreshold'           then draw           else return ()   return imageRGB8@@ -84,31 +107,27 @@       let image' = getCocoImageByFileName coco imageFile       case image' of         Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."-        Just (image, annotations) -> do+        Just (_, annotations) -> do           let categories = toCategoryMap coco           imageBin' <- readImage imagePath           case imageBin' of-            Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read."+            Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read. : " ++ show err             Right imageBin -> do               imageRGB8 <- drawBoundingBox imageBin annotations categories               putImage (Right imageRGB8)     else do       putImage (Left imagePath) -showDetectionImage :: Coco -> FilePath -> FilePath -> FilePath -> Maybe Double -> IO ()-showDetectionImage coco cocoFile cocoResultFile imageFile scoreThreshold = do-  let cocoFileNameWithoutExtension = takeBaseName cocoFile-      imageDir = takeDirectory (takeDirectory cocoFile) </> cocoFileNameWithoutExtension </> "images"-      imagePath = imageDir </> imageFile-  cocoResult <- readCocoResult cocoResultFile-  let image' = getCocoResultByFileName coco cocoResult imageFile+showDetectionImage :: (Show a) => CocoMap -> FilePath -> Maybe Double -> [a] -> Maybe (Image PixelRGB8 -> a -> IO (Image PixelRGB8)) -> IO ()+showDetectionImage cocoMap imageFile scoreThreshold properties overlay = do+  let imagePath = getImageDir cocoMap </> imageFile+  let image' = getCocoResult cocoMap imageFile   case image' of     Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."-    Just (image, annotations) -> do+    Just (_, annotations) -> do       imageBin' <- readImage imagePath       case imageBin' of-        Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read."+        Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read. : " ++ show err         Right imageBin -> do-          let categories = toCategoryMap coco-          imageRGB8 <- drawDetectionBoundingBox imageBin (filter (\res -> cocoResultImageId res == cocoImageId image) cocoResult) categories scoreThreshold-          putImage (Right imageRGB8)+          drawDetectionBoundingBox imageBin annotations properties (cocoMapCocoCategory cocoMap) scoreThreshold overlay+            >>= putImage . Right

@@ -11,24 +11,15 @@ module RiskWeaver.Draw where  import Codec.Picture qualified as I-import Control.Exception.Safe-  ( SomeException (..),-    throwIO,-    try,-  ) import Control.Monad-  ( MonadPlus,-    forM_,+  ( forM_,     when,   )-import Data.ByteString qualified as BS-import Data.ByteString.Internal qualified as BSI import Data.Int import Data.Vector.Storable qualified as V-import Data.Word import Foreign.ForeignPtr qualified as F import Foreign.Ptr qualified as F-import GHC.Exts (IsList (fromList))+import GHC.ForeignPtr qualified as GF import Language.C.Inline qualified as C import System.IO.Unsafe import Prelude hiding (max, min)@@ -58,10 +49,8 @@   let channel = 3 :: Int       (I.Image org_w org_h org_vec) = input       img@(I.Image w h vec) = I.generateImage (\_ _ -> (I.PixelRGB8 0 0 0)) width height :: I.Image I.PixelRGB8-      (org_fptr, org_len) = V.unsafeToForeignPtr0 org_vec-      org_whc = fromIntegral $ org_w * org_h * channel-      (fptr, len) = V.unsafeToForeignPtr0 vec-      whc = fromIntegral $ w * h * channel+      (org_fptr, _) = V.unsafeToForeignPtr0 org_vec+      (fptr, _) = V.unsafeToForeignPtr0 vec   F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr fptr $ \ptr2 -> do     let src = F.castPtr ptr1         dst = F.castPtr ptr2@@ -97,8 +86,8 @@  drawLine :: Int -> Int -> Int -> Int -> (Int, Int, Int) -> I.Image I.PixelRGB8 -> IO () drawLine x0 y0 x1 y1 (r, g, b) input = do-  let img@(I.Image w h vec) = input-      (fptr, len) = V.unsafeToForeignPtr0 vec+  let (I.Image w h vec) = input+      (fptr, _) = V.unsafeToForeignPtr0 vec   F.withForeignPtr fptr $ \ptr2 -> do     let iw = fromIntegral w         ih = fromIntegral h@@ -163,8 +152,8 @@  drawChar :: Int -> Int -> Int -> (Int, Int, Int) -> (Int, Int, Int) -> I.Image I.PixelRGB8 -> IO () drawChar ascii_code x0 y0 (r, g, b) (br, bg, bb) input = do-  let img@(I.Image w h vec) = input-      (fptr, len) = V.unsafeToForeignPtr0 vec+  let (I.Image w h vec) = input+      (fptr, _) = V.unsafeToForeignPtr0 vec   F.withForeignPtr fptr $ \ptr2 -> do     let iw = fromIntegral w         ih = fromIntegral h@@ -320,10 +309,8 @@   let channel = 3 :: Int       (I.Image org_w org_h org_vec) = input       img@(I.Image w h vec) = I.generateImage (\_ _ -> (I.PixelRGB8 0 0 0)) width height :: I.Image I.PixelRGB8-      (org_fptr, org_len) = V.unsafeToForeignPtr0 org_vec-      org_whc = fromIntegral $ org_w * org_h * channel-      (fptr, len) = V.unsafeToForeignPtr0 vec-      whc = fromIntegral $ w * h * channel+      (org_fptr, _) = V.unsafeToForeignPtr0 org_vec+      (fptr, _) = V.unsafeToForeignPtr0 vec   F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr fptr $ \ptr2 -> do     let src = F.castPtr ptr1         dst = F.castPtr ptr2@@ -404,3 +391,192 @@   I.ImageY16 _ -> Y16   I.ImageYA16 _ -> YA16   I.ImageY32 _ -> Y32++-- allocates memory for a new image+createImage :: Int -> Int -> IO (I.Image I.PixelRGB8)+createImage w h = do+  when (w < 0) $ error ("trying to createImage of negative dim: " ++ show w)+  when (h < 0) $ error ("trying to createImage of negative dim: " ++ show h)+  fp <- GF.mallocPlainForeignPtrBytes size+  return $ I.Image w h (V.unsafeFromForeignPtr fp 0 size)+  where+    size = w * h * 3++cloneImage :: I.Image I.PixelRGB8 -> IO (I.Image I.PixelRGB8)+cloneImage input = do+  let (I.Image w h vec) = input+      (org_fptr, _) = V.unsafeToForeignPtr0 vec+  newImage <- createImage w h+  let (I.Image _ _ dst_vec) = newImage+      (dst_fptr, _) = V.unsafeToForeignPtr0 dst_vec+  F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr dst_fptr $ \ptr2 -> do+    let src = F.castPtr ptr1+        dst = F.castPtr ptr2+        iw = fromIntegral w+        ih = fromIntegral h+        ichannel = 3+    [C.block| void {+        uint8_t* src = $(uint8_t* src);+        uint8_t* dst = $(uint8_t* dst);+        int w = $(int iw);+        int h = $(int ih);+        int channel = $(int ichannel);+        for(int y=0;y<h;y++){+          for(int x=0;x<w;x++){+            for(int c=0;c<channel;c++){+              dst[(y*w+x)*channel+c] = src[(y*w+x)*channel+c];+            }+          }+        }+    } |]+    return newImage++pasteImage :: I.Image I.PixelRGB8 -> Int -> Int -> I.Image I.PixelRGB8 -> IO ()+pasteImage input offsetx offsety destination = do+  let (I.Image w h vec) = input+      (org_fptr, _) = V.unsafeToForeignPtr0 vec+      (I.Image dst_w dst_h dst_vec) = destination+      (dst_fptr, _) = V.unsafeToForeignPtr0 dst_vec+  F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr dst_fptr $ \ptr2 -> do+    let src = F.castPtr ptr1+        dst = F.castPtr ptr2+        iw = fromIntegral w+        ih = fromIntegral h+        iorg_w = fromIntegral dst_w+        iorg_h = fromIntegral dst_h+        ichannel = 3+        ioffsetx = fromIntegral offsetx+        ioffsety = fromIntegral offsety+    [C.block| void {+        uint8_t* src = $(uint8_t* src);+        uint8_t* dst = $(uint8_t* dst);+        int w = $(int iw);+        int h = $(int ih);+        int ow = $(int iorg_w);+        int oh = $(int iorg_h);+        int channel = $(int ichannel);+        int offsetx = $(int ioffsetx);+        int offsety = $(int ioffsety);+        for(int y=0;y<h;y++){+          for(int x=0;x<w;x++){+            for(int c=0;c<channel;c++){+              int sy = y + offsety;+              int sx = x + offsetx;+              if(sx >= 0 && sx < ow &&+                 sy >= 0 && sy < oh){+                 dst[(sy*ow+sx)*channel+c] = src[(y*w+x)*channel+c];+              }+            }+          }+        }+    } |]++concatImagesH :: [I.Image I.PixelRGB8] -> IO (I.Image I.PixelRGB8)+concatImagesH [] = error "concatImagesH: empty list"+concatImagesH (x : []) = return x+concatImagesH (x : y : xs) = do+  newImage <- concatImageByHorizontal x y+  concatImagesH (newImage : xs)++concatImagesV :: [I.Image I.PixelRGB8] -> IO (I.Image I.PixelRGB8)+concatImagesV [] = error "concatImagesH: empty list"+concatImagesV (x : []) = return x+concatImagesV (x : y : xs) = do+  newImage <- concatImageByVertical x y+  concatImagesH (newImage : xs)++concatImageByHorizontal :: I.Image I.PixelRGB8 -> I.Image I.PixelRGB8 -> IO (I.Image I.PixelRGB8)+concatImageByHorizontal left right = do+  let (I.Image lw lh lvec) = left+      (lfptr, _) = V.unsafeToForeignPtr0 lvec+      (I.Image rw rh rvec) = right+      (rfptr, _) = V.unsafeToForeignPtr0 rvec+  newImage <- createImage (lw + rw) (P.max lh rh)+  let (I.Image w h dst_vec) = newImage+      (dst_fptr, _) = V.unsafeToForeignPtr0 dst_vec+  F.withForeignPtr lfptr $ \lptr -> F.withForeignPtr rfptr $ \rptr -> F.withForeignPtr dst_fptr $ \dptr -> do+    let lsrc = F.castPtr lptr+        rsrc = F.castPtr rptr+        dst = F.castPtr dptr+        iw = fromIntegral w+        ih = fromIntegral h+        ilw = fromIntegral lw+        ilh = fromIntegral lh+        irw = fromIntegral rw+        irh = fromIntegral rh+        ichannel = 3+    [C.block| void {+        uint8_t* lsrc = $(uint8_t* lsrc);+        uint8_t* rsrc = $(uint8_t* rsrc);+        uint8_t* dst = $(uint8_t* dst);+        int w = $(int iw);+        int h = $(int ih);+        int lw = $(int ilw);+        int lh = $(int ilh);+        int rw = $(int irw);+        int rh = $(int irh);+        int channel = $(int ichannel);+        for(int y=0;y<h;y++){+          for(int x=0;x<w;x++){+            for(int c=0;c<channel;c++){+              if(x < lw){+                dst[(y*w+x)*channel+c] = lsrc[(y*lw+x)*channel+c];+              } else {+                dst[(y*w+x)*channel+c] = rsrc[(y*rw+(x-lw))*channel+c];+              }+            }+          }+        }+    } |]+    return newImage++concatImageByVertical :: I.Image I.PixelRGB8 -> I.Image I.PixelRGB8 -> IO (I.Image I.PixelRGB8)+concatImageByVertical top bottom = do+  let (I.Image tw th tvec) = top+      (tfptr, _) = V.unsafeToForeignPtr0 tvec+      (I.Image bw bh bvec) = bottom+      (bfptr, _) = V.unsafeToForeignPtr0 bvec+  newImage <- createImage (P.max tw bw) (th + bh)+  let (I.Image w h dst_vec) = newImage+      (dst_fptr, _) = V.unsafeToForeignPtr0 dst_vec+  F.withForeignPtr tfptr $ \tptr -> F.withForeignPtr bfptr $ \bptr -> F.withForeignPtr dst_fptr $ \dptr -> do+    let tsrc = F.castPtr tptr+        bsrc = F.castPtr bptr+        dst = F.castPtr dptr+        iw = fromIntegral w+        ih = fromIntegral h+        itw = fromIntegral tw+        ith = fromIntegral th+        ibw = fromIntegral bw+        ibh = fromIntegral bh+        ichannel = 3+    [C.block| void {+        uint8_t* tsrc = $(uint8_t* tsrc);+        uint8_t* bsrc = $(uint8_t* bsrc);+        uint8_t* dst = $(uint8_t* dst);+        int w = $(int iw);+        int h = $(int ih);+        int tw = $(int itw);+        int th = $(int ith);+        int bw = $(int ibw);+        int bh = $(int ibh);+        int channel = $(int ichannel);+        for(int y=0;y<h;y++){+          for(int x=0;x<w;x++){+            for(int c=0;c<channel;c++){+              if(y < th){+                dst[(y*w+x)*channel+c] = tsrc[(y*tw+x)*channel+c];+              } else {+                dst[(y*w+x)*channel+c] = bsrc[((y-th)*bw+x)*channel+c];+              }+            }+          }+        }+    } |]+    return newImage++concatImages2x2 :: I.Image I.PixelRGB8 -> I.Image I.PixelRGB8 -> I.Image I.PixelRGB8 -> I.Image I.PixelRGB8 -> IO (I.Image I.PixelRGB8)+concatImages2x2 topLeft topRight bottomLeft bottomRight = do+  top <- concatImageByHorizontal topLeft topRight+  bottom <- concatImageByHorizontal bottomLeft bottomRight+  concatImageByVertical top bottom

@@ -1,8 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {- This module provides COCO format parser of object detection dataset. Aeson is used for parsing JSON. -}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-}@@ -10,26 +12,21 @@  module RiskWeaver.Format.Coco where -import Codec.Picture.Metadata (Value (Double))-import Control.Monad (ap)+import Control.Concurrent.Async+import Control.DeepSeq import Data.Aeson import Data.ByteString.Lazy qualified as BS-import Data.List (maximumBy, sort, sortBy) import Data.Map qualified as Map-import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics---- import Debug.Trace (trace)--- myTrace :: Show a => String -> a -> a--- myTrace s a = trace (s ++ ": " ++ show a) a+import System.FilePath (takeBaseName, takeDirectory, (</>)) -newtype ImageId = ImageId {unImageId :: Int} deriving (Show, Ord, Eq, Generic)+newtype ImageId = ImageId {unImageId :: Int} deriving (Show, Ord, Eq, Generic, NFData) -newtype CategoryId = CategoryId {unCategoryId :: Int} deriving (Show, Ord, Eq, Generic)+newtype CategoryId = CategoryId {unCategoryId :: Int} deriving (Show, Ord, Eq, Generic, NFData) -newtype Score = Score {unScore :: Double} deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic)+newtype Score = Score {unScore :: Double} deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic, NFData)  instance FromJSON ImageId where   parseJSON = withScientific "image_id" $ \n -> do@@ -62,6 +59,8 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoInfo+ instance FromJSON CocoInfo where   parseJSON = withObject "info" $ \o -> do     cocoInfoYear <- o .: "year"@@ -90,6 +89,8 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoLicense+ instance FromJSON CocoLicense where   parseJSON = withObject "license" $ \o -> do     cocoLicenseId <- o .: "id"@@ -115,6 +116,8 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoImage+ instance FromJSON CocoImage where   parseJSON = withObject "image" $ \o -> do     cocoImageId <- o .: "id"@@ -140,6 +143,8 @@   = CoCoBoundingBox (Double, Double, Double, Double)   deriving (Show, Eq, Generic) +instance NFData CoCoBoundingBox+ -- (x, y, width, height)  data CocoAnnotation = CocoAnnotation@@ -153,6 +158,8 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoAnnotation+ instance FromJSON CocoAnnotation where   parseJSON = withObject "annotation" $ \o -> do     cocoAnnotationId <- o .: "id"@@ -160,7 +167,13 @@     cocoAnnotationCategory <- o .: "category_id"     cocoAnnotationSegment <- o .:? "segmentation"     cocoAnnotationArea <- o .: "area"-    cocoAnnotationBbox <- fmap (\[x, y, w, h] -> CoCoBoundingBox (x, y, w, h)) $ o .: "bbox"+    cocoAnnotationBbox <-+      fmap+        ( \case+            x : y : w : h : _ -> CoCoBoundingBox (x, y, w, h)+            v -> error $ "Annotation's bounding box needs 4 numbers. : " ++ show v+        )+        $ o .: "bbox"     cocoAnnotationIsCrowd <- o .:? "iscrowd"     return CocoAnnotation {..} @@ -183,6 +196,8 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoCategory+ instance FromJSON CocoCategory where   parseJSON = withObject "category" $ \o -> do     cocoCategoryId <- o .: "id"@@ -207,6 +222,8 @@   }   deriving (Show, Eq, Generic) +instance NFData Coco+ instance FromJSON Coco where   parseJSON = withObject "coco" $ \o -> do     cocoInfo <- o .:? "info"@@ -236,12 +253,20 @@   }   deriving (Show, Eq, Generic) +instance NFData CocoResult+ instance FromJSON CocoResult where   parseJSON = withObject "result" $ \o -> do     cocoResultImageId <- o .: "image_id"     cocoResultCategory <- o .: "category_id"     cocoResultScore <- o .: "score"-    cocoResultBbox <- fmap (\[x, y, w, h] -> CoCoBoundingBox (x, y, w, h)) $ o .: "bbox"+    cocoResultBbox <-+      fmap+        ( \case+            x : y : w : h : _ -> CoCoBoundingBox (x, y, w, h)+            v -> error $ "Annotation's bounding box needs 4 numbers. : " ++ show v+        )+        $ o .: "bbox"     return CocoResult {..}  instance ToJSON CocoResult where@@ -317,12 +342,40 @@     cocoMapCocoResult :: Map.Map ImageId [CocoResult],     cocoMapFilepath :: Map.Map ImageId FilePath,     cocoMapImageIds :: [ImageId],-    cocoMapCategoryIds :: [CategoryId]+    cocoMapCategoryIds :: [CategoryId],+    cocoMapCoco :: Coco,+    cocoMapCocoFile :: FilePath,+    cocoMapCocoResultFile :: FilePath   }   deriving (Show, Eq, Generic) -toCocoMap :: Coco -> [CocoResult] -> CocoMap-toCocoMap coco cocoResult =+instance NFData CocoMap++getImageDir :: CocoMap -> FilePath+getImageDir cocoMap =+  let cocoFileNameWithoutExtension = takeBaseName $ cocoMapCocoFile cocoMap+      imageDir = takeDirectory (takeDirectory $ cocoMapCocoFile cocoMap) </> cocoFileNameWithoutExtension </> "images"+   in imageDir++class CocoMapable a where+  getCocoResult :: CocoMap -> a -> Maybe (CocoImage, [CocoResult])++instance CocoMapable FilePath where+  getCocoResult cocoMap filePath = do+    imageIds <- Map.lookup filePath $ cocoMapImageId cocoMap+    let imageId = head imageIds+    image <- Map.lookup imageId $ cocoMapCocoImage cocoMap+    results <- Map.lookup imageId $ cocoMapCocoResult cocoMap+    return (image, results)++instance CocoMapable ImageId where+  getCocoResult cocoMap imageId = do+    image <- Map.lookup imageId $ cocoMapCocoImage cocoMap+    results <- Map.lookup imageId $ cocoMapCocoResult cocoMap+    return (image, results)++toCocoMap :: Coco -> [CocoResult] -> FilePath -> FilePath -> CocoMap+toCocoMap coco cocoResult cocoFile cocoResultFile =   let cocoMapImageId = toImageId coco       cocoMapCocoImage = toCocoImageMap coco       cocoMapCocoAnnotation = toCocoAnnotationMap coco@@ -331,4 +384,51 @@       cocoMapFilepath = toFilepathMap coco       cocoMapImageIds = map (\CocoImage {..} -> cocoImageId) $ cocoImages coco       cocoMapCategoryIds = map (\CocoCategory {..} -> cocoCategoryId) $ cocoCategories coco+      cocoMapCoco = coco+      cocoMapCocoFile = cocoFile+      cocoMapCocoResultFile = cocoResultFile    in CocoMap {..}++readCocoMap :: FilePath -> FilePath -> IO CocoMap+readCocoMap cocoFile cocoResultFile =+  withAsync (readCoco cocoFile) $ \coco' -> do+    withAsync (readCocoResult cocoResultFile) $ \cocoResult' -> do+      coco <- wait coco'+      cocoResult <- wait cocoResult'+      return $ toCocoMap coco cocoResult cocoFile cocoResultFile++resampleCocoMapWithImageIds :: CocoMap -> [ImageId] -> (Coco, [CocoResult])+resampleCocoMapWithImageIds cocoMap imageIds =+  let zipedImageIds = zip [1 ..] imageIds+      newImageIds = (ImageId . fst) <$> zipedImageIds+      imageIdsMap = Map.fromList zipedImageIds+      cocoImages' =+        map+          ( \imageId ->+              let orgImageId = imageIdsMap Map.! (unImageId imageId)+                  img = (cocoMapCocoImage cocoMap) Map.! orgImageId+               in img {cocoImageId = imageId}+          )+          newImageIds+      cocoAnnotations' =+        let annotations' = concat $ flip map newImageIds $ \imageId ->+              let orgImageId = imageIdsMap Map.! (unImageId imageId)+                  annotations = Map.findWithDefault [] orgImageId (cocoMapCocoAnnotation cocoMap)+                  newAnnotations = map (\annotation -> annotation {cocoAnnotationImageId = imageId}) annotations+               in newAnnotations+            zippedAnnotations = zip [1 ..] annotations'+            alignedAnnotations = map (\(newId, annotation) -> annotation {cocoAnnotationId = newId}) zippedAnnotations+         in alignedAnnotations+      newCoco =+        (cocoMapCoco cocoMap)+          { cocoImages = cocoImages',+            cocoAnnotations = cocoAnnotations'+          }+      newCocoResult = concat $ flip map newImageIds $ \imageId ->+        let orgImageId = imageIdsMap Map.! (unImageId imageId)+            cocoResult = Map.findWithDefault [] orgImageId (cocoMapCocoResult cocoMap)+            newCocoResult' = map (\cocoResult' -> cocoResult' {cocoResultImageId = imageId}) cocoResult+         in newCocoResult'+   in (newCoco, newCocoResult)++

@@ -6,11 +6,13 @@  module RiskWeaver.Metric where -import Data.List (maximumBy, sort, sortBy)+import Control.Parallel.Strategies+import Data.List (maximumBy, sortBy)+import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe)-import RiskWeaver.Format.Coco import GHC.Generics+import RiskWeaver.Format.Coco  newtype IOU = IOU Double deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic) @@ -39,6 +41,7 @@       intersection = max 0 (x' - x) * max 0 (y' - y)       union = w1 * h1 + w2 * h2 - intersection    in IOU $ intersection / union+{-# INLINEABLE iou #-}  iog :: CoCoBoundingBox -> CoCoBoundingBox -> IOG iog (CoCoBoundingBox (x1, y1, w1, h1)) (CoCoBoundingBox (x2, y2, w2, h2)) =@@ -53,6 +56,7 @@       intersection = max 0 (x' - x) * max 0 (y' - y)       groundTruth = w1 * h1    in IOG $ intersection / groundTruth+{-# INLINEABLE iog #-}  -- | Calculate TP or FP -- | TP = true positive@@ -60,9 +64,8 @@ -- | When the value is True, TP is calculated. -- | When the value is False, FP is calculated. toTPorFP :: CocoMap -> ImageId -> CategoryId -> IOU -> ([(CocoResult, Bool)], Int)-toTPorFP cocoMap@CocoMap {..} imageId categoryId iouThresh =-  let cocoImage = cocoMapCocoImage Map.! imageId-      -- detections is sorted by score in descending order.+toTPorFP CocoMap {..} imageId categoryId iouThresh =+  let -- detections is sorted by score in descending order.       detections :: [CocoResult] =         case Map.lookup imageId cocoMapCocoResult of           Nothing -> []@@ -81,26 +84,27 @@         if Map.size gts == 0           then Nothing           else-            let ious = map (\(i, gt) -> (i, gt, iou (cocoAnnotationBbox gt) (cocoResultBbox cocoResult))) $ Map.toList gts+            let ious = map (\(i', gt') -> (i', gt', iou (cocoAnnotationBbox gt') (cocoResultBbox cocoResult))) $ Map.toList gts                 (i, gt, iou') = maximumBy (\(_, _, iou1) (_, _, iou2) -> compare iou1 iou2) ious              in if iou' >= iouThresh                   then Just (i, gt, iou')                   else Nothing       loop :: [CocoResult] -> Map.Map Int CocoAnnotation -> [(CocoResult, Bool)]       loop [] _ = []-      loop (result : results) groundTruths =-        case getGTWithMaxScore result groundTruths of-          Nothing -> (result, False) : loop results groundTruths-          Just (i, gt, iou') ->-            let groundTruths' = Map.delete i groundTruths-             in (result, True) : loop results groundTruths'+      loop (result : results) groundTruths' =+        case getGTWithMaxScore result groundTruths' of+          Nothing -> (result, False) : loop results groundTruths'+          Just (i, _, _) ->+            let groundTruths'' = Map.delete i groundTruths'+             in (result, True) : loop results groundTruths''    in (loop detections groundTruths, numOfGroundTruths)  apForCategory :: CocoMap -> CategoryId -> IOU -> Double apForCategory cocoMap@CocoMap {..} categoryId iouThresh =-  let for = flip map-      imageIds = cocoMapImageIds-      tpAndFps' = for imageIds $ \imageId -> toTPorFP cocoMap imageId categoryId iouThresh+  let imageIds = cocoMapImageIds+      tpAndFps' =+        map (\imageId -> toTPorFP cocoMap imageId categoryId iouThresh) imageIds+          `using` parList rdeepseq       numOfGroundTruths = sum $ map snd tpAndFps'       tpAndFps = sortBy (\res0 res1 -> compare (cocoResultScore (fst res1)) (cocoResultScore (fst res0))) $ concat $ map fst tpAndFps'       precisionRecallCurve :: [(CocoResult, Bool)] -> Int -> Int -> [(Double, Double)]@@ -127,62 +131,50 @@ mAP cocoMap@CocoMap {..} iouThresh =   let categoryIds = cocoMapCategoryIds       aps = map (\categoryId -> apForCategory cocoMap categoryId iouThresh) categoryIds-   in (sum aps / fromIntegral (length aps), zip categoryIds aps)+      aps' = aps `using` parList rdeepseq+   in (sum aps' / fromIntegral (length aps'), zip categoryIds aps') -data ConfusionMatrix = ConfusionMatrix-  { confusionMatrixRecall :: Map.Map (Gt CategoryId) (Map.Map (Dt CategoryId) Int),-    confusionMatrixPrecision :: Map.Map (Dt CategoryId) (Map.Map (Gt CategoryId) Int),-    confusionMatrixCategoryIds :: [CategoryId]-  }-  deriving (Show, Eq, Ord) -instance Semigroup ConfusionMatrix where-  ConfusionMatrix recall1 precision1 categoryIds1 <> ConfusionMatrix recall2 precision2 categoryIds2 =-    ConfusionMatrix-      { confusionMatrixRecall = recall,-        confusionMatrixPrecision = precision,-        confusionMatrixCategoryIds = categoryIds-      }-    where-      recall = Map.unionWith (Map.unionWith (+)) recall1 recall2-      precision = Map.unionWith (Map.unionWith (+)) precision1 precision2-      categoryIds = categoryIds1+f1ForCategory :: CocoMap -> CategoryId -> IOU -> Score -> Double+f1ForCategory cocoMap@CocoMap {..} categoryId iouThresh scoreThresh =+  let imageIds = cocoMapImageIds+      tpAndFps' =+        map (\imageId -> toTPorFP cocoMap imageId categoryId iouThresh) imageIds+          `using` parList rdeepseq+      numOfGroundTruths = sum $ map snd tpAndFps'+      tpAndFps = sortBy (\res0 res1 -> compare (cocoResultScore (fst res1)) (cocoResultScore (fst res0))) $ concat $ map fst tpAndFps'+      precisionRecallCurve :: [(CocoResult, Bool)] -> Int -> Int -> [(Double, Double, Score)]+      precisionRecallCurve [] _ _ = []+      precisionRecallCurve (x : xs) accTps accNum =+        (precision, recall, cocoResultScore (fst x)) : precisionRecallCurve xs accTps' accNum'+        where+          accTps' = if snd x then accTps + 1 else accTps+          accNum' = accNum + 1+          precision = fromIntegral accTps' / fromIntegral accNum'+          recall = fromIntegral accTps' / fromIntegral numOfGroundTruths+      precisionRecallCurve' = reverse $ precisionRecallCurve tpAndFps 0 0+      f1 :: [(Double, Double, Score)] -> Double+      f1 [] = 0+      f1 ((precision, recall, score) : xs) = +        if score >= scoreThresh+          then 2 * (precision * recall) / (precision + recall)+          else f1 xs+   in f1 precisionRecallCurve' -confusionMatrix :: CocoMap -> IOU -> Score -> ConfusionMatrix-confusionMatrix cocoMap@CocoMap {..} iouThresh scoreThresh =-  foldl (<>) (ConfusionMatrix Map.empty Map.empty cocoMapCategoryIds) $-    map (confusionMatrixForImage cocoMap iouThresh scoreThresh) cocoMapImageIds+mF1 :: CocoMap -> IOU -> Score -> (Double, [(CategoryId, Double)])+mF1 cocoMap@CocoMap {..} iouThresh scoreThresh =+  let categoryIds = cocoMapCategoryIds+      f1s = map (\categoryId -> f1ForCategory cocoMap categoryId iouThresh scoreThresh) categoryIds+      f1s' = f1s `using` parList rdeepseq+   in (sum f1s' / fromIntegral (length f1s'), zip categoryIds f1s') -confusionMatrixForImage :: CocoMap -> IOU -> Score -> ImageId -> ConfusionMatrix-confusionMatrixForImage cocoMap@CocoMap {..} iouThresh scoreThresh imageId =-  ConfusionMatrix-    { confusionMatrixRecall = recall,-      confusionMatrixPrecision = precision,-      confusionMatrixCategoryIds = cocoMapCategoryIds-    }-  where-    gts = fromMaybe [] $ Map.lookup imageId cocoMapCocoAnnotation-    dts = fromMaybe [] $ Map.lookup imageId cocoMapCocoResult-    for = flip map-    recall = foldl (Map.unionWith (Map.unionWith (+))) Map.empty $-      for gts $ \gt ->-        let iousWithDt = sortBy (\(iou0, _) (iou1, _) -> compare iou1 iou0) $ flip map dts $ \dt -> (iou (cocoAnnotationBbox gt) (cocoResultBbox dt), dt)-            filteredDt = filter (\(iou, dt) -> iou >= iouThresh && cocoResultScore dt >= scoreThresh) iousWithDt-            categoryFilter = filter (\(iou, dt) -> cocoAnnotationCategory gt == cocoResultCategory dt) filteredDt-         in case categoryFilter of-              [] ->-                case filteredDt of-                  [] -> Map.singleton (Gt $ cocoAnnotationCategory gt) $ Map.singleton DtBackground 1-                  (iou, dt) : _ -> Map.singleton (Gt $ cocoAnnotationCategory gt) $ Map.singleton (Dt $ cocoResultCategory dt) 1-              (iou, dt) : _ -> Map.singleton (Gt $ cocoAnnotationCategory gt) $ Map.singleton (Dt $ cocoResultCategory dt) 1-    precision = foldl (Map.unionWith (Map.unionWith (+))) Map.empty $-      for dts $ \dt ->-        let iousWithGt = sortBy (\(iou0, _) (iou1, _) -> compare iou1 iou0) $ flip map gts $ \gt -> (iou (cocoAnnotationBbox gt) (cocoResultBbox dt), gt)-            filteredGt = filter (\(iou, gt) -> iou >= iouThresh) iousWithGt-            categoryFilter = filter (\(iou, gt) -> cocoAnnotationCategory gt == cocoResultCategory dt) filteredGt-         in case categoryFilter of-              [] ->-                case filteredGt of-                  [] -> Map.singleton (Dt $ cocoResultCategory dt) $ Map.singleton GtBackground 1-                  (iou, gt) : _ -> Map.singleton (Dt $ cocoResultCategory dt) $ Map.singleton (Gt $ cocoAnnotationCategory gt) 1-              (iou, gt) : _ -> Map.singleton (Dt $ cocoResultCategory dt) $ Map.singleton (Gt $ cocoAnnotationCategory gt) 1+sortAndGroup :: (Ord k) => [(k, v)] -> Map k [v]+sortAndGroup assocs = Map.fromListWith (++) [(k, [v]) | (k, v) <- assocs]++average :: forall a f. (Num a, Foldable f, Fractional a) => f a -> a+average xs+  | null xs = 0+  | otherwise =+      uncurry (/)+        . foldl (\(!total, !count) x -> (total + x, count + 1)) (0, 0)+        $ xs

@@ -0,0 +1,26 @@+module RiskWeaver.Pip where++newtype Polygon = Polygon [(Double, Double)] deriving (Show, Eq)++newtype Point = Point (Double, Double) deriving (Show, Eq)++-- | When given a polygon and a point, returns True if the point is inside the polygon.+pointInPolygon :: Polygon -> Point -> Bool+pointInPolygon (Polygon polygon) (Point point) =+  let points = zip polygon (tail polygon)+      wn = flip map points $ \(vi, vii) ->+        if ((snd vi <= snd point) && (snd vii > snd point))+          then+            let vt = (snd point - snd vi) / (snd vii - snd vi)+             in if (fst point < (fst vi + (vt * (fst vii - fst vi))))+                  then 1+                  else 0+          else+            if ((snd vi > snd point) && (snd vii <= snd point))+              then+                let vt = (snd point - snd vi) / (snd vii - snd vi)+                 in if (fst point < (fst vi + (vt * (fst vii - fst vi))))+                      then -1+                      else 0+              else 0+   in (foldl (+) 0 wn) /= (0 :: Int)