diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/bin/sample-risk.hs b/bin/sample-risk.hs new file mode 100644 --- /dev/null +++ b/bin/sample-risk.hs @@ -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 diff --git a/risk-weaver.cabal b/risk-weaver.cabal --- a/risk-weaver.cabal +++ b/risk-weaver.cabal @@ -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 @@ -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 diff --git a/src/RiskWeaver/Cmd/BDD.hs b/src/RiskWeaver/Cmd/BDD.hs --- a/src/RiskWeaver/Cmd/BDD.hs +++ b/src/RiskWeaver/Cmd/BDD.hs @@ -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 + } diff --git a/src/RiskWeaver/Cmd/Core.hs b/src/RiskWeaver/Cmd/Core.hs --- a/src/RiskWeaver/Cmd/Core.hs +++ b/src/RiskWeaver/Cmd/Core.hs @@ -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 diff --git a/src/RiskWeaver/DSL/BDD.hs b/src/RiskWeaver/DSL/BDD.hs --- a/src/RiskWeaver/DSL/BDD.hs +++ b/src/RiskWeaver/DSL/BDD.hs @@ -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 + diff --git a/src/RiskWeaver/DSL/Core.hs b/src/RiskWeaver/DSL/Core.hs --- a/src/RiskWeaver/DSL/Core.hs +++ b/src/RiskWeaver/DSL/Core.hs @@ -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 + diff --git a/src/RiskWeaver/Display.hs b/src/RiskWeaver/Display.hs --- a/src/RiskWeaver/Display.hs +++ b/src/RiskWeaver/Display.hs @@ -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 diff --git a/src/RiskWeaver/Draw.hs b/src/RiskWeaver/Draw.hs --- a/src/RiskWeaver/Draw.hs +++ b/src/RiskWeaver/Draw.hs @@ -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 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= 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 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 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 diff --git a/src/RiskWeaver/Format/Coco.hs b/src/RiskWeaver/Format/Coco.hs --- a/src/RiskWeaver/Format/Coco.hs +++ b/src/RiskWeaver/Format/Coco.hs @@ -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) + + diff --git a/src/RiskWeaver/Metric.hs b/src/RiskWeaver/Metric.hs --- a/src/RiskWeaver/Metric.hs +++ b/src/RiskWeaver/Metric.hs @@ -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 diff --git a/src/RiskWeaver/Pip.hs b/src/RiskWeaver/Pip.hs new file mode 100644 --- /dev/null +++ b/src/RiskWeaver/Pip.hs @@ -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)