risk-weaver (empty) → 0.1.0.0
raw patch · 13 files changed
+1856/−0 lines, 13 filesdep +JuicyPixelsdep +aesondep +base
Dependencies added: JuicyPixels, aeson, base, bytestring, containers, file-embed, filepath, inline-c, optparse-applicative, random, risk-weaver, safe-exceptions, sixel, text, transformers, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- app/Main.hs +9/−0
- risk-weaver.cabal +73/−0
- src/RiskWeaver/Cmd/BDD.hs +182/−0
- src/RiskWeaver/Cmd/Core.hs +237/−0
- src/RiskWeaver/DSL/BDD.hs +193/−0
- src/RiskWeaver/DSL/Core.hs +91/−0
- src/RiskWeaver/Display.hs +114/−0
- src/RiskWeaver/Draw.hs +406/−0
- src/RiskWeaver/Format/Coco.hs +334/−0
- src/RiskWeaver/Metric.hs +188/−0
- test/Main.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for risk-weaver++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Junji Hashimoto++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import RiskWeaver.Cmd.Core qualified as Core+import RiskWeaver.Cmd.BDD qualified as BDD++main = Core.baseMain BDD.bddCommand
+ risk-weaver.cabal view
@@ -0,0 +1,73 @@+cabal-version: 3.0+name: risk-weaver++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++synopsis: A DSL for Risk-oriented Object Detection Requirements+description: Please see the README on GitHub at <https://github.com/jst-qaml/risk-weaver#readme>++license: MIT+license-file: LICENSE+author: Junji Hashimoto+maintainer: junji.hashimoto@gree.net++category: Development+build-type: Simple++extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++library+ import: warnings+ exposed-modules: RiskWeaver.Format.Coco+ , RiskWeaver.DSL.Core+ , RiskWeaver.DSL.BDD+ , RiskWeaver.Draw+ , RiskWeaver.Display+ , RiskWeaver.Metric+ , RiskWeaver.Cmd.Core+ , RiskWeaver.Cmd.BDD+ build-depends: base == 4.*+ , JuicyPixels >= 3.3.8 && < 3.4+ , aeson >= 2.1 && < 2.3+ , bytestring >= 0.11.5 && < 0.12+ , containers >= 0.6.7 && < 0.7+ , file-embed >= 0.0.15 && < 0.1+ , filepath >= 1.4.100 && < 1.5+ , inline-c >= 0.9.1 && < 0.10+ , optparse-applicative >= 0.18.1 && < 0.19+ , random >= 1.2.1 && < 1.3+ , safe-exceptions >= 0.1.7 && < 0.2+ , sixel >= 0.1.2 && < 0.2+ , text >= 2.0.2 && < 2.1+ , transformers >= 0.6.1 && < 0.7+ , vector >= 0.13.1 && < 0.14+ hs-source-dirs: src+ default-language: GHC2021++executable risk-weaver-exe+ import: warnings+ main-is: Main.hs+ build-depends: base == 4.*+ , risk-weaver+ hs-source-dirs: app+ default-language: GHC2021++ +test-suite risk-weaver-test+ import: warnings+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base == 4.*+ , risk-weaver
+ src/RiskWeaver/Cmd/BDD.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module RiskWeaver.Cmd.BDD where++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 Data.List (sortBy)+import Data.Map qualified as Map+import Data.Text qualified as T+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import RiskWeaver.Format.Coco+import RiskWeaver.Metric++import Options.Applicative+import System.Random+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)++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+ 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++ -- 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+ }+ writeCoco cocoOutputFile newCoco+++bddCommand :: RiskCommands+bddCommand = RiskCommands {+ showRisk = RiskWeaver.Cmd.BDD.showRisk,+ generateRiskWeightedDataset = RiskWeaver.Cmd.BDD.generateRiskWeightedDataset+}
+ src/RiskWeaver/Cmd/Core.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++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 RiskWeaver.Display+import RiskWeaver.Format.Coco+import qualified RiskWeaver.Metric as Metric+import RiskWeaver.Metric++import Options.Applicative+import System.Random+import Text.Printf++data CocoCommand+ = ListImages {cocoFile :: FilePath}+ | ListCategories {cocoFile :: FilePath}+ | ListAnnotations {cocoFile :: FilePath}+ | ListCocoResult {cocoResultFile :: FilePath}+ | ShowImage+ { cocoFile :: FilePath,+ imageFile :: FilePath,+ enableBoundingBox :: Bool+ }+ | ShowDetectionImage+ { cocoFile :: FilePath,+ cocoResultFile :: FilePath,+ imageFile :: FilePath,+ scoreThreshold :: Maybe Double+ }+ | Evaluate+ { cocoFile :: FilePath,+ cocoResultFile :: FilePath,+ iouThreshold :: Maybe Double,+ scoreThreshold :: Maybe Double,+ imageId :: Maybe Int+ }+ | ShowFalseNegative+ { cocoFile :: FilePath,+ cocoResultFile :: FilePath,+ iouThreshold :: Maybe Double,+ scoreThreshold :: Maybe Double,+ imageId :: Maybe Int+ }+ | ShowRisk+ { cocoFile :: FilePath,+ cocoResultFile :: FilePath,+ iouThreshold :: Maybe Double,+ scoreThreshold :: Maybe Double,+ imageId :: Maybe Int+ }+ | GenerateRiskWeightedDataset+ { cocoFile :: FilePath,+ cocoResultFile :: FilePath,+ cocoOutputFile :: FilePath,+ iouThreshold :: Maybe Double,+ scoreThreshold :: Maybe Double+ }+ | BashCompletion+ 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 ()+ }++listImages :: Coco -> IO ()+listImages coco = do+ putStrLn "-- list images --"+ -- first column is image id+ -- second column is image file name+ -- third column is image width+ -- fourth column is image height+ -- fifth column is image license+ -- sixth column is image date captured+ putStrLn "id\tfile_name\twidth\theight\tlicense\tdate_captured"+ forM_ (cocoImages coco) $ \CocoImage {..} -> do+ putStrLn $ show (unImageId cocoImageId) ++ "\t" ++ T.unpack cocoImageFileName ++ "\t" ++ show cocoImageWidth ++ "\t" ++ show cocoImageHeight ++ "\t" ++ show cocoImageLicense ++ "\t" ++ show cocoImageDateCoco++listCategories :: Coco -> IO ()+listCategories coco = do+ putStrLn "-- list categories --"+ -- first column is category id+ -- second column is category name+ -- third column is category supercategory+ putStrLn "id\tname\tsupercategory"+ forM_ (cocoCategories coco) $ \CocoCategory {..} -> do+ putStrLn $ show cocoCategoryId ++ "\t" ++ T.unpack cocoCategoryName ++ "\t" ++ T.unpack cocoCategorySupercategory++listAnnotations :: Coco -> IO ()+listAnnotations coco = do+ putStrLn "-- list annotations --"+ -- first column is annotation id+ -- second column is annotation image id+ -- third column is annotation category id+ -- fourth column is annotation segmentation+ -- fifth column is annotation area+ -- sixth column is annotation bbox+ -- seventh column is annotation iscrowd+ putStrLn "id\timage_id\tcategory_id\tsegmentation\tarea\tbbox\tiscrowd"+ forM_ (cocoAnnotations coco) $ \CocoAnnotation {..} -> do+ putStrLn $ show cocoAnnotationId ++ "\t" ++ show cocoAnnotationImageId ++ "\t" ++ show cocoAnnotationCategory ++ "\t" ++ show cocoAnnotationSegment ++ "\t" ++ show cocoAnnotationArea ++ "\t" ++ show cocoAnnotationBbox ++ "\t" ++ show cocoAnnotationIsCrowd++listCocoResult :: [CocoResult] -> IO ()+listCocoResult cocoResults = do+ putStrLn "-- list coco result --"+ -- first column is image id+ -- second column is category id+ -- third column is score+ -- fourth column is bbox+ putStrLn "image_id\tcategory_id\tscore\tbbox"+ 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+ -- Inline the file content by tepmlate haskell+ let file = $(embedFile "bash_completion.d/risk-weaver-exe")+ BS.putStr file++opts :: Parser CocoCommand+opts =+ subparser+ ( command "list-images" (info (ListImages <$> argument str (metavar "FILE")) (progDesc "list all images of coco file"))+ <> command "list-categories" (info (ListCategories <$> argument str (metavar "FILE")) (progDesc "list all categories of coco file"))+ <> 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 "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"))+ )++baseMain :: RiskCommands -> IO ()+baseMain RiskCommands{..} = do+ cmd <- customExecParser (prefs showHelpOnEmpty) (info (helper <*> opts) (fullDesc <> progDesc "coco command line tool"))++ case cmd of+ BashCompletion -> bashCompletion+ ListImages cocoFile -> do+ coco <- readCoco cocoFile+ listImages coco+ ListCategories cocoFile -> do+ coco <- readCoco cocoFile+ listCategories coco+ ListAnnotations cocoFile -> do+ coco <- readCoco cocoFile+ listAnnotations coco+ ListCocoResult cocoResultFile -> do+ cocoResult <- readCocoResult cocoResultFile+ listCocoResult cocoResult+ 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)+ GenerateRiskWeightedDataset cocoFile cocoResultFile cocoOutputFile iouThreshold scoreThreshold -> do+ coco <- readCoco cocoFile+ cocoResult <- readCocoResult cocoResultFile+ generateRiskWeightedDataset coco cocoResult cocoOutputFile iouThreshold scoreThreshold+ _ -> return ()
+ src/RiskWeaver/DSL/BDD.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++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 Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import RiskWeaver.Format.Coco++data BoundingBoxGT = BoundingBoxGT+ { x :: Double,+ y :: Double,+ w :: Double,+ h :: Double,+ 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)++data Class+ = Background+ | Pedestrian+ | Rider+ | Car+ | Truck+ | Bus+ | Train+ | Motorcycle+ | Bicycle+ deriving (Show, Eq)++data FNError+ = Boundary+ | LowScore+ | MissClass+ | Occulusion+ deriving (Show, Eq)++instance BoundingBox BoundingBoxGT where+ type Detection _ = BoundingBoxDT+ type ClassG _ = Class+ type ClassD _ = Class+ data ErrorType _+ = FalsePositive+ | FalseNegative (Set FNError)+ | TruePositive+ | TrueNegative+ deriving (Show, Eq)+ type InterestArea _ = [(Double, Double)]+ type InterestObject _ = BoundingBoxGT+ data Env _ = MyEnv+ { envGroundTruth :: Vector BoundingBoxGT,+ envDetection :: Vector BoundingBoxDT,+ envConfidenceScoreThresh :: Double,+ envIoUThresh :: Double+ }+ type Idx _ = Int+ type Risk _ = Double++ 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+ 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++ 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+ detectD :: Env BoundingBoxGT -> Detection BoundingBoxGT -> Maybe BoundingBoxGT+ detectD _ _ = undefined+ errorType :: Env BoundingBoxGT -> Detection BoundingBoxGT -> Maybe (ErrorType BoundingBoxGT)+ errorType _ _ = undefined++ 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++ riskD _ _ = undefined+ riskBB _ = undefined++ confusionMatrixRecallBB _ = undefined+ confusionMatrixAccuracyBB _ = undefined+ confusionMatrixRecallBB' _ = undefined+ confusionMatrixAccuracyBB' _ = undefined+ errorGroupsBB _ = undefined++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++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)]
+ src/RiskWeaver/DSL/Core.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module RiskWeaver.DSL.Core where++import Control.Monad.Trans.Reader (ReaderT, ask)+import Data.Kind (Type)+import Data.Map (Map)+import Data.Vector (Vector)++class BoundingBox a where+ type Detection a :: Type+ type ClassG a :: Type+ type ClassD a :: Type+ data ErrorType a :: Type+ type InterestArea a :: Type+ type InterestObject a :: Type+ data Env a :: Type+ type Idx a :: Type+ type Risk a :: Type++ riskE :: Env a -> Risk a+ interestArea :: Env a -> InterestArea a+ interestObject :: Env a -> InterestObject a+ groundTruth :: Env a -> Vector a+ detection :: Env a -> Vector (Detection a)+ confidenceScoreThresh :: Env a -> Double+ ioUThresh :: Env a -> Double+ scoreD :: Detection a -> Double+ sizeD :: Detection a -> Double+ classD :: Detection a -> ClassG a+ idD :: Detection a -> Idx a++ isFrontD :: Detection a -> Detection a -> Bool+ isBackD :: Detection a -> Detection a -> Bool+ isLeftD :: Detection a -> Detection a -> Bool+ isRightD :: Detection a -> Detection a -> Bool+ isTopD :: Detection a -> Detection a -> Bool+ isBottomD :: Detection a -> Detection a -> Bool+ isBackGroundD :: ClassD a -> Bool+ detectD :: Env a -> Detection a -> Maybe a+ errorType :: Env a -> Detection a -> Maybe (ErrorType a)++ sizeG :: a -> Double+ classG :: a -> ClassG a+ angle :: a -> Detection a -> Double+ idG :: a -> Idx a+ ioU :: a -> Detection a -> Double+ ioG :: a -> Detection a -> Double+ ioD :: a -> Detection a -> Double+ detectG :: Env a -> a -> Maybe (Detection a)++ isInIeterestAreaD :: InterestArea a -> Detection a -> Bool+ isInIeterestAreaG :: InterestArea a -> a -> Bool++ riskD :: Env a -> Detection a -> Risk a+ riskBB :: Env a -> Risk a++ 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])++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])++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+ env <- ask+ foldl add init <$> mapM fn (groundTruth @a env)++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+ env <- ask+ foldl add init <$> mapM fn (detection @a env)
+ src/RiskWeaver/Display.hs view
@@ -0,0 +1,114 @@+module RiskWeaver.Display where++import Codec.Picture+import Control.Monad+import Data.Map qualified as Map+import Data.OSC1337 qualified as OSC+import Data.Sixel qualified as Sixel+import Data.Text qualified as T+import RiskWeaver.Draw+import RiskWeaver.Format.Coco+import System.Environment (lookupEnv)+import System.FilePath (takeBaseName, takeDirectory, (</>))+import Text.Printf++putImage :: Either FilePath (Image PixelRGB8) -> IO ()+putImage image' = do+ termProgram <- lookupEnv "TERM_PROGRAM"+ image <- case image' of+ Left imagePath -> do+ imageBin <- readImage imagePath+ case imageBin of+ Left err -> fail $ "Image file " ++ imagePath ++ " can not be read."+ Right imageBin -> return (convertRGB8 imageBin)+ Right image -> return image+ case termProgram of+ Just "iTerm.app" -> do+ OSC.putOSC image+ putStrLn ""+ Just "vscode" -> do+ Sixel.putSixel image+ putStrLn ""+ _ -> do+ Sixel.putSixel image+ putStrLn ""++drawBoundingBox :: DynamicImage -> [CocoAnnotation] -> Map.Map CategoryId CocoCategory -> IO (Image PixelRGB8)+drawBoundingBox imageBin annotations categories = do+ let imageRGB8 = convertRGB8 imageBin+ forM_ annotations $ \annotation -> do+ let (CoCoBoundingBox (bx, by, bw, bh)) = cocoAnnotationBbox annotation+ x = round bx+ y = round by+ width = round bw+ height = round bh+ drawRect x y (x + width) (y + height) (255, 0, 0) imageRGB8+ 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+ let imageRGB8 = convertRGB8 imageBin+ forM_ annotations $ \annotation -> do+ let (CoCoBoundingBox (bx, by, bw, bh)) = cocoResultBbox annotation+ x = round bx+ y = round by+ width = round bw+ height = round bh+ draw = do+ drawRect x y (x + width) (y + height) (255, 0, 0) imageRGB8+ 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+ -- 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+ then draw+ else return ()+ return imageRGB8++-- Show image by sixel+showImage :: Coco -> FilePath -> FilePath -> Bool -> IO ()+showImage coco cocoFile imageFile enableBoundingBox = do+ -- Get a diretory of image file from cocoFile's filename.+ -- cocoFile's filename is the same as image directory.+ -- For example, cocoFile is annotations/test.json, then image directory is test/images, and lable directory is test/labels.+ -- Get a parent parent directory(grand parent directory) of cocoFile's filename, and add a directory of images+ let cocoFileNameWithoutExtension = takeBaseName cocoFile+ imageDir = takeDirectory (takeDirectory cocoFile) </> cocoFileNameWithoutExtension </> "images"+ imagePath = imageDir </> imageFile+ if enableBoundingBox+ then do+ let image' = getCocoImageByFileName coco imageFile+ case image' of+ Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."+ Just (image, annotations) -> do+ let categories = toCategoryMap coco+ imageBin' <- readImage imagePath+ case imageBin' of+ Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read."+ 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+ case image' of+ Nothing -> putStrLn $ "Image file " ++ imageFile ++ " is not found."+ Just (image, annotations) -> do+ imageBin' <- readImage imagePath+ case imageBin' of+ Left err -> putStrLn $ "Image file " ++ imagePath ++ " can not be read."+ Right imageBin -> do+ let categories = toCategoryMap coco+ imageRGB8 <- drawDetectionBoundingBox imageBin (filter (\res -> cocoResultImageId res == cocoImageId image) cocoResult) categories scoreThreshold+ putImage (Right imageRGB8)
+ src/RiskWeaver/Draw.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module RiskWeaver.Draw where++import Codec.Picture qualified as I+import Control.Exception.Safe+ ( SomeException (..),+ throwIO,+ try,+ )+import Control.Monad+ ( MonadPlus,+ 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 Language.C.Inline qualified as C+import System.IO.Unsafe+import Prelude hiding (max, min)+import Prelude qualified as P++C.include "<stdint.h>"++data PixelFormat+ = Y8+ | YF+ | YA8+ | RGB8+ | RGBF+ | RGBA8+ | YCbCr8+ | CMYK8+ | CMYK16+ | RGBA16+ | RGB16+ | Y16+ | YA16+ | Y32+ deriving (Show, Eq)++centerCrop :: Int -> Int -> I.Image I.PixelRGB8 -> I.Image I.PixelRGB8+centerCrop width height input = unsafePerformIO $ do+ 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+ F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr fptr $ \ptr2 -> do+ let src = F.castPtr ptr1+ dst = F.castPtr ptr2+ iw = fromIntegral w+ ih = fromIntegral h+ iorg_w = fromIntegral org_w+ iorg_h = fromIntegral org_h+ ichannel = fromIntegral channel+ [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);+ int ow = $(int iorg_w);+ int oh = $(int iorg_h);+ int offsetx = (ow - w)/2;+ int offsety = (oh - h)/2;+ for(int y=0;y<h;y++){+ for(int x=0;x<w;x++){+ for(int c=0;c<channel;c++){+ int sy = y + offsety;+ int sx = x + offsetx;+ if(sx >= 0 && sx < ow &&+ sy >= 0 && sy < oh){+ dst[(y*w+x)*channel+c] = src[(sy*ow+sx)*channel+c];+ }+ }+ }+ }+ } |]+ return img++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+ F.withForeignPtr fptr $ \ptr2 -> do+ let iw = fromIntegral w+ ih = fromIntegral h+ ix0 = fromIntegral x0+ iy0 = fromIntegral y0+ ix1 = fromIntegral x1+ iy1 = fromIntegral y1+ ir = fromIntegral r+ ig = fromIntegral g+ ib = fromIntegral b+ dst = F.castPtr ptr2+ [C.block| void {+ uint8_t* dst = $(uint8_t* dst);+ int w = $(int iw);+ int h = $(int ih);+ int x0 = $(int ix0);+ int y0 = $(int iy0);+ int x1 = $(int ix1);+ int y1 = $(int iy1);+ int r = $(int ir);+ int g = $(int ig);+ int b = $(int ib);+ int channel = 3;+ int sign_x = x1 - x0 >= 0 ? 1 : -1;+ int sign_y = y1 - y0 >= 0 ? 1 : -1;+ int abs_x = x1 - x0 >= 0 ? x1 - x0 : x0 - x1;+ int abs_y = y1 - y0 >= 0 ? y1 - y0 : y0 - y1;+ if(abs_x>=abs_y){+ for(int x=x0;x!=x1;x+=sign_x){+ int y = (x-x0) * (y1-y0) / (x1-x0) + y0;+ if(y >=0 && y < h &&+ x >=0 && x < w) {+ dst[(y*w+x)*channel+0] = r;+ dst[(y*w+x)*channel+1] = g;+ dst[(y*w+x)*channel+2] = b;+ }+ }+ } else {+ for(int y=y0;y!=y1;y+=sign_y){+ int x = (y-y0) * (x1-x0) / (y1-y0) + x0;+ if(y >=0 && y < h &&+ x >=0 && x < w) {+ dst[(y*w+x)*channel+0] = r;+ dst[(y*w+x)*channel+1] = g;+ dst[(y*w+x)*channel+2] = b;+ }+ }+ }+ } |]++drawRect :: Int -> Int -> Int -> Int -> (Int, Int, Int) -> I.Image I.PixelRGB8 -> IO ()+drawRect x0 y0 x1 y1 (r, g, b) input = do+ drawLine x0 y0 (x1 + 1) y0 (r, g, b) input+ drawLine x0 y0 x0 (y1 + 1) (r, g, b) input+ drawLine x0 y1 (x1 + 1) y1 (r, g, b) input+ drawLine x1 y0 x1 (y1 + 1) (r, g, b) input++drawString :: String -> Int -> Int -> (Int, Int, Int) -> (Int, Int, Int) -> I.Image I.PixelRGB8 -> IO ()+drawString text x0 y0 (r, g, b) (br, bg, bb) input = do+ forM_ (zip [0 ..] text) $ \(i, ch) -> do+ drawChar (fromEnum ch) (x0 + i * 8) y0 (r, g, b) (br, bg, bb) input++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+ F.withForeignPtr fptr $ \ptr2 -> do+ let iw = fromIntegral w+ ih = fromIntegral h+ ix0 = fromIntegral x0+ iy0 = fromIntegral y0+ ir = fromIntegral r+ ig = fromIntegral g+ ib = fromIntegral b+ ibr = fromIntegral br+ ibg = fromIntegral bg+ ibb = fromIntegral bb+ dst = F.castPtr ptr2+ iascii_code = fromIntegral ascii_code+ [C.block| void {+ uint8_t* dst = $(uint8_t* dst);+ int w = $(int iw);+ int h = $(int ih);+ int x0 = $(int ix0);+ int y0 = $(int iy0);+ int r = $(int ir);+ int g = $(int ig);+ int b = $(int ib);+ int br = $(int ibr);+ int bg = $(int ibg);+ int bb = $(int ibb);+ int ascii_code = $(int iascii_code);+ int channel = 3;+ int char_width = 8;+ int char_height = 8;+ char fonts[95][8] = { // 0x20 to 0x7e+ { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00},+ { 0x18, 0x3C, 0x3C, 0x18, 0x18, 0x00, 0x18, 0x00},+ { 0x36, 0x36, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00},+ { 0x36, 0x36, 0x7F, 0x36, 0x7F, 0x36, 0x36, 0x00},+ { 0x0C, 0x3E, 0x03, 0x1E, 0x30, 0x1F, 0x0C, 0x00},+ { 0x00, 0x63, 0x33, 0x18, 0x0C, 0x66, 0x63, 0x00},+ { 0x1C, 0x36, 0x1C, 0x6E, 0x3B, 0x33, 0x6E, 0x00},+ { 0x06, 0x06, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00},+ { 0x18, 0x0C, 0x06, 0x06, 0x06, 0x0C, 0x18, 0x00},+ { 0x06, 0x0C, 0x18, 0x18, 0x18, 0x0C, 0x06, 0x00},+ { 0x00, 0x66, 0x3C, 0xFF, 0x3C, 0x66, 0x00, 0x00},+ { 0x00, 0x0C, 0x0C, 0x3F, 0x0C, 0x0C, 0x00, 0x00},+ { 0x00, 0x00, 0x00, 0x00, 0x00, 0x0C, 0x0C, 0x06},+ { 0x00, 0x00, 0x00, 0x3F, 0x00, 0x00, 0x00, 0x00},+ { 0x00, 0x00, 0x00, 0x00, 0x00, 0x0C, 0x0C, 0x00},+ { 0x60, 0x30, 0x18, 0x0C, 0x06, 0x03, 0x01, 0x00},+ { 0x3E, 0x63, 0x73, 0x7B, 0x6F, 0x67, 0x3E, 0x00},+ { 0x0C, 0x0E, 0x0C, 0x0C, 0x0C, 0x0C, 0x3F, 0x00},+ { 0x1E, 0x33, 0x30, 0x1C, 0x06, 0x33, 0x3F, 0x00},+ { 0x1E, 0x33, 0x30, 0x1C, 0x30, 0x33, 0x1E, 0x00},+ { 0x38, 0x3C, 0x36, 0x33, 0x7F, 0x30, 0x78, 0x00},+ { 0x3F, 0x03, 0x1F, 0x30, 0x30, 0x33, 0x1E, 0x00},+ { 0x1C, 0x06, 0x03, 0x1F, 0x33, 0x33, 0x1E, 0x00},+ { 0x3F, 0x33, 0x30, 0x18, 0x0C, 0x0C, 0x0C, 0x00},+ { 0x1E, 0x33, 0x33, 0x1E, 0x33, 0x33, 0x1E, 0x00},+ { 0x1E, 0x33, 0x33, 0x3E, 0x30, 0x18, 0x0E, 0x00},+ { 0x00, 0x0C, 0x0C, 0x00, 0x00, 0x0C, 0x0C, 0x00},+ { 0x00, 0x0C, 0x0C, 0x00, 0x00, 0x0C, 0x0C, 0x06},+ { 0x18, 0x0C, 0x06, 0x03, 0x06, 0x0C, 0x18, 0x00},+ { 0x00, 0x00, 0x3F, 0x00, 0x00, 0x3F, 0x00, 0x00},+ { 0x06, 0x0C, 0x18, 0x30, 0x18, 0x0C, 0x06, 0x00},+ { 0x1E, 0x33, 0x30, 0x18, 0x0C, 0x00, 0x0C, 0x00},+ { 0x3E, 0x63, 0x7B, 0x7B, 0x7B, 0x03, 0x1E, 0x00},+ { 0x0C, 0x1E, 0x33, 0x33, 0x3F, 0x33, 0x33, 0x00},+ { 0x3F, 0x66, 0x66, 0x3E, 0x66, 0x66, 0x3F, 0x00},+ { 0x3C, 0x66, 0x03, 0x03, 0x03, 0x66, 0x3C, 0x00},+ { 0x1F, 0x36, 0x66, 0x66, 0x66, 0x36, 0x1F, 0x00},+ { 0x7F, 0x46, 0x16, 0x1E, 0x16, 0x46, 0x7F, 0x00},+ { 0x7F, 0x46, 0x16, 0x1E, 0x16, 0x06, 0x0F, 0x00},+ { 0x3C, 0x66, 0x03, 0x03, 0x73, 0x66, 0x7C, 0x00},+ { 0x33, 0x33, 0x33, 0x3F, 0x33, 0x33, 0x33, 0x00},+ { 0x1E, 0x0C, 0x0C, 0x0C, 0x0C, 0x0C, 0x1E, 0x00},+ { 0x78, 0x30, 0x30, 0x30, 0x33, 0x33, 0x1E, 0x00},+ { 0x67, 0x66, 0x36, 0x1E, 0x36, 0x66, 0x67, 0x00},+ { 0x0F, 0x06, 0x06, 0x06, 0x46, 0x66, 0x7F, 0x00},+ { 0x63, 0x77, 0x7F, 0x7F, 0x6B, 0x63, 0x63, 0x00},+ { 0x63, 0x67, 0x6F, 0x7B, 0x73, 0x63, 0x63, 0x00},+ { 0x1C, 0x36, 0x63, 0x63, 0x63, 0x36, 0x1C, 0x00},+ { 0x3F, 0x66, 0x66, 0x3E, 0x06, 0x06, 0x0F, 0x00},+ { 0x1E, 0x33, 0x33, 0x33, 0x3B, 0x1E, 0x38, 0x00},+ { 0x3F, 0x66, 0x66, 0x3E, 0x36, 0x66, 0x67, 0x00},+ { 0x1E, 0x33, 0x07, 0x0E, 0x38, 0x33, 0x1E, 0x00},+ { 0x3F, 0x2D, 0x0C, 0x0C, 0x0C, 0x0C, 0x1E, 0x00},+ { 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x3F, 0x00},+ { 0x33, 0x33, 0x33, 0x33, 0x33, 0x1E, 0x0C, 0x00},+ { 0x63, 0x63, 0x63, 0x6B, 0x7F, 0x77, 0x63, 0x00},+ { 0x63, 0x63, 0x36, 0x1C, 0x1C, 0x36, 0x63, 0x00},+ { 0x33, 0x33, 0x33, 0x1E, 0x0C, 0x0C, 0x1E, 0x00},+ { 0x7F, 0x63, 0x31, 0x18, 0x4C, 0x66, 0x7F, 0x00},+ { 0x1E, 0x06, 0x06, 0x06, 0x06, 0x06, 0x1E, 0x00},+ { 0x03, 0x06, 0x0C, 0x18, 0x30, 0x60, 0x40, 0x00},+ { 0x1E, 0x18, 0x18, 0x18, 0x18, 0x18, 0x1E, 0x00},+ { 0x08, 0x1C, 0x36, 0x63, 0x00, 0x00, 0x00, 0x00},+ { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xFF},+ { 0x0C, 0x0C, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00},+ { 0x00, 0x00, 0x1E, 0x30, 0x3E, 0x33, 0x6E, 0x00},+ { 0x07, 0x06, 0x06, 0x3E, 0x66, 0x66, 0x3B, 0x00},+ { 0x00, 0x00, 0x1E, 0x33, 0x03, 0x33, 0x1E, 0x00},+ { 0x38, 0x30, 0x30, 0x3e, 0x33, 0x33, 0x6E, 0x00},+ { 0x00, 0x00, 0x1E, 0x33, 0x3f, 0x03, 0x1E, 0x00},+ { 0x1C, 0x36, 0x06, 0x0f, 0x06, 0x06, 0x0F, 0x00},+ { 0x00, 0x00, 0x6E, 0x33, 0x33, 0x3E, 0x30, 0x1F},+ { 0x07, 0x06, 0x36, 0x6E, 0x66, 0x66, 0x67, 0x00},+ { 0x0C, 0x00, 0x0E, 0x0C, 0x0C, 0x0C, 0x1E, 0x00},+ { 0x30, 0x00, 0x30, 0x30, 0x30, 0x33, 0x33, 0x1E},+ { 0x07, 0x06, 0x66, 0x36, 0x1E, 0x36, 0x67, 0x00},+ { 0x0E, 0x0C, 0x0C, 0x0C, 0x0C, 0x0C, 0x1E, 0x00},+ { 0x00, 0x00, 0x33, 0x7F, 0x7F, 0x6B, 0x63, 0x00},+ { 0x00, 0x00, 0x1F, 0x33, 0x33, 0x33, 0x33, 0x00},+ { 0x00, 0x00, 0x1E, 0x33, 0x33, 0x33, 0x1E, 0x00},+ { 0x00, 0x00, 0x3B, 0x66, 0x66, 0x3E, 0x06, 0x0F},+ { 0x00, 0x00, 0x6E, 0x33, 0x33, 0x3E, 0x30, 0x78},+ { 0x00, 0x00, 0x3B, 0x6E, 0x66, 0x06, 0x0F, 0x00},+ { 0x00, 0x00, 0x3E, 0x03, 0x1E, 0x30, 0x1F, 0x00},+ { 0x08, 0x0C, 0x3E, 0x0C, 0x0C, 0x2C, 0x18, 0x00},+ { 0x00, 0x00, 0x33, 0x33, 0x33, 0x33, 0x6E, 0x00},+ { 0x00, 0x00, 0x33, 0x33, 0x33, 0x1E, 0x0C, 0x00},+ { 0x00, 0x00, 0x63, 0x6B, 0x7F, 0x7F, 0x36, 0x00},+ { 0x00, 0x00, 0x63, 0x36, 0x1C, 0x36, 0x63, 0x00},+ { 0x00, 0x00, 0x33, 0x33, 0x33, 0x3E, 0x30, 0x1F},+ { 0x00, 0x00, 0x3F, 0x19, 0x0C, 0x26, 0x3F, 0x00},+ { 0x38, 0x0C, 0x0C, 0x07, 0x0C, 0x0C, 0x38, 0x00},+ { 0x18, 0x18, 0x18, 0x00, 0x18, 0x18, 0x18, 0x00},+ { 0x07, 0x0C, 0x0C, 0x38, 0x0C, 0x0C, 0x07, 0x00},+ { 0x6E, 0x3B, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00} + };+ for(int y=y0;y<y0+char_height;y++){+ for(int x=x0;x<x0+char_width;x++){+ if(y >=0 && y < h &&+ x >=0 && x < w) {+ int dx = x-x0;+ int dy = y-y0;+ int bit = + ascii_code > 0x20 && ascii_code < 0x7f ?+ fonts[ascii_code-0x20][dy] & (0x1 << dx) :+ 0;+ if (bit) {+ dst[(y*w+x)*channel+0] = r;+ dst[(y*w+x)*channel+1] = g;+ dst[(y*w+x)*channel+2] = b;+ } else {+ dst[(y*w+x)*channel+0] = br;+ dst[(y*w+x)*channel+1] = bg;+ dst[(y*w+x)*channel+2] = bb;+ }+ }+ }+ }+ } |]++resizeRGB8 :: Int -> Int -> Bool -> I.Image I.PixelRGB8 -> I.Image I.PixelRGB8+resizeRGB8 width height keepAspectRatio input = unsafePerformIO $ do+ 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+ F.withForeignPtr org_fptr $ \ptr1 -> F.withForeignPtr fptr $ \ptr2 -> do+ let src = F.castPtr ptr1+ dst = F.castPtr ptr2+ iw = fromIntegral w+ ih = fromIntegral h+ iorg_w = fromIntegral org_w+ iorg_h = fromIntegral org_h+ ichannel = fromIntegral channel+ ckeepAspectRatio = if keepAspectRatio then 1 else 0+ [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);+ int ow = $(int iorg_w);+ int oh = $(int iorg_h);+ int keepAspectRatio = $(int ckeepAspectRatio);+ if(keepAspectRatio){+ int t0h = h;+ int t0w = ow * h / oh;+ int t1h = oh * w / ow;+ int t1w = w;+ if (t0w > w) {+ int offset = (h - (oh * w / ow))/2;+ for(int y=offset;y<h-offset;y++){+ for(int x=0;x<w;x++){+ for(int c=0;c<channel;c++){+ int sy = (y-offset) * ow / w;+ int sx = x * ow / w;+ if(sy >= 0 && sy < oh){+ dst[(y*w+x)*channel+c] = src[(sy*ow+sx)*channel+c];+ }+ }+ }+ }+ } else {+ int offset = (w - (ow * h / oh))/2;+ for(int y=0;y<h;y++){+ for(int x=offset;x<w-offset;x++){+ for(int c=0;c<channel;c++){+ int sy = y * oh / h;+ int sx = (x-offset) * oh / h;+ if(sx >= 0 && sx < ow){+ dst[(y*w+x)*channel+c] = src[(sy*ow+sx)*channel+c];+ }+ }+ }+ }+ }+ } else {+ for(int y=0;y<h;y++){+ for(int x=0;x<w;x++){+ for(int c=0;c<channel;c++){+ int sy = y * oh / h;+ int sx = x * ow / w;+ dst[(y*w+x)*channel+c] = src[(sy*ow+sx)*channel+c];+ }+ }+ }+ }+ } |]+ return img++pixelFormat :: I.DynamicImage -> PixelFormat+pixelFormat image = case image of+ I.ImageY8 _ -> Y8+ I.ImageYF _ -> YF+ I.ImageYA8 _ -> YA8+ I.ImageRGB8 _ -> RGB8+ I.ImageRGBF _ -> RGBF+ I.ImageRGBA8 _ -> RGBA8+ I.ImageYCbCr8 _ -> YCbCr8+ I.ImageCMYK8 _ -> CMYK8+ I.ImageCMYK16 _ -> CMYK16+ I.ImageRGBA16 _ -> RGBA16+ I.ImageRGB16 _ -> RGB16+ I.ImageY16 _ -> Y16+ I.ImageYA16 _ -> YA16+ I.ImageY32 _ -> Y32
+ src/RiskWeaver/Format/Coco.hs view
@@ -0,0 +1,334 @@+{-+This module provides COCO format parser of object detection dataset.+Aeson is used for parsing JSON.+-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}++module RiskWeaver.Format.Coco where++import Codec.Picture.Metadata (Value (Double))+import Control.Monad (ap)+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++newtype ImageId = ImageId {unImageId :: Int} deriving (Show, Ord, Eq, Generic)++newtype CategoryId = CategoryId {unCategoryId :: Int} deriving (Show, Ord, Eq, Generic)++newtype Score = Score {unScore :: Double} deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic)++instance FromJSON ImageId where+ parseJSON = withScientific "image_id" $ \n -> do+ return $ ImageId $ round n++instance ToJSON ImageId where+ toJSON (ImageId n) = toJSON n++instance FromJSON CategoryId where+ parseJSON = withScientific "category_id" $ \n -> do+ return $ CategoryId $ round n++instance ToJSON CategoryId where+ toJSON (CategoryId n) = toJSON n++instance FromJSON Score where+ parseJSON = withScientific "score" $ \n -> do+ return $ Score $ realToFrac n++instance ToJSON Score where+ toJSON (Score n) = toJSON n++data CocoInfo = CocoInfo+ { cocoInfoYear :: Int,+ cocoInfoVersion :: Text,+ cocoInfoDescription :: Text,+ cocoInfoContributor :: Text,+ cocoInfoUrl :: Text,+ cocoInfoDateCreated :: Text+ }+ deriving (Show, Eq, Generic)++instance FromJSON CocoInfo where+ parseJSON = withObject "info" $ \o -> do+ cocoInfoYear <- o .: "year"+ cocoInfoVersion <- o .: "version"+ cocoInfoDescription <- o .: "description"+ cocoInfoContributor <- o .: "contributor"+ cocoInfoUrl <- o .: "url"+ cocoInfoDateCreated <- o .: "date_created"+ return CocoInfo {..}++instance ToJSON CocoInfo where+ toJSON CocoInfo {..} =+ object+ [ "year" .= cocoInfoYear,+ "version" .= cocoInfoVersion,+ "description" .= cocoInfoDescription,+ "contributor" .= cocoInfoContributor,+ "url" .= cocoInfoUrl,+ "date_created" .= cocoInfoDateCreated+ ]++data CocoLicense = CocoLicense+ { cocoLicenseId :: Int,+ cocoLicenseName :: Text,+ cocoLicenseUrl :: Text+ }+ deriving (Show, Eq, Generic)++instance FromJSON CocoLicense where+ parseJSON = withObject "license" $ \o -> do+ cocoLicenseId <- o .: "id"+ cocoLicenseName <- o .: "name"+ cocoLicenseUrl <- o .: "url"+ return CocoLicense {..}++instance ToJSON CocoLicense where+ toJSON CocoLicense {..} =+ object+ [ "id" .= cocoLicenseId,+ "name" .= cocoLicenseName,+ "url" .= cocoLicenseUrl+ ]++data CocoImage = CocoImage+ { cocoImageId :: ImageId,+ cocoImageWidth :: Int,+ cocoImageHeight :: Int,+ cocoImageFileName :: Text,+ cocoImageLicense :: Maybe Int,+ cocoImageDateCoco :: Maybe Text+ }+ deriving (Show, Eq, Generic)++instance FromJSON CocoImage where+ parseJSON = withObject "image" $ \o -> do+ cocoImageId <- o .: "id"+ cocoImageWidth <- o .: "width"+ cocoImageHeight <- o .: "height"+ cocoImageFileName <- o .: "file_name"+ cocoImageLicense <- o .:? "license"+ cocoImageDateCoco <- o .:? "date_captured"+ return CocoImage {..}++instance ToJSON CocoImage where+ toJSON CocoImage {..} =+ object+ [ "id" .= cocoImageId,+ "width" .= cocoImageWidth,+ "height" .= cocoImageHeight,+ "file_name" .= cocoImageFileName,+ "license" .= cocoImageLicense,+ "date_captured" .= cocoImageDateCoco+ ]++newtype CoCoBoundingBox+ = CoCoBoundingBox (Double, Double, Double, Double)+ deriving (Show, Eq, Generic)++-- (x, y, width, height)++data CocoAnnotation = CocoAnnotation+ { cocoAnnotationId :: Int,+ cocoAnnotationImageId :: ImageId,+ cocoAnnotationCategory :: CategoryId,+ cocoAnnotationSegment :: Maybe [[Double]], -- [[x1, y1, x2, y2, ...]]+ cocoAnnotationArea :: Double,+ cocoAnnotationBbox :: CoCoBoundingBox,+ cocoAnnotationIsCrowd :: Maybe Int+ }+ deriving (Show, Eq, Generic)++instance FromJSON CocoAnnotation where+ parseJSON = withObject "annotation" $ \o -> do+ cocoAnnotationId <- o .: "id"+ cocoAnnotationImageId <- o .: "image_id"+ cocoAnnotationCategory <- o .: "category_id"+ cocoAnnotationSegment <- o .:? "segmentation"+ cocoAnnotationArea <- o .: "area"+ cocoAnnotationBbox <- fmap (\[x, y, w, h] -> CoCoBoundingBox (x, y, w, h)) $ o .: "bbox"+ cocoAnnotationIsCrowd <- o .:? "iscrowd"+ return CocoAnnotation {..}++instance ToJSON CocoAnnotation where+ toJSON CocoAnnotation {..} =+ object+ [ "id" .= cocoAnnotationId,+ "image_id" .= cocoAnnotationImageId,+ "category_id" .= cocoAnnotationCategory,+ "segmentation" .= cocoAnnotationSegment,+ "area" .= cocoAnnotationArea,+ "bbox" .= case cocoAnnotationBbox of CoCoBoundingBox (x, y, w, h) -> [x, y, w, h],+ "iscrowd" .= cocoAnnotationIsCrowd+ ]++data CocoCategory = CocoCategory+ { cocoCategoryId :: CategoryId,+ cocoCategoryName :: Text,+ cocoCategorySupercategory :: Text+ }+ deriving (Show, Eq, Generic)++instance FromJSON CocoCategory where+ parseJSON = withObject "category" $ \o -> do+ cocoCategoryId <- o .: "id"+ cocoCategoryName <- o .: "name"+ cocoCategorySupercategory <- o .: "supercategory"+ return CocoCategory {..}++instance ToJSON CocoCategory where+ toJSON CocoCategory {..} =+ object+ [ "id" .= cocoCategoryId,+ "name" .= cocoCategoryName,+ "supercategory" .= cocoCategorySupercategory+ ]++data Coco = Coco+ { cocoInfo :: Maybe CocoInfo,+ cocoLicenses :: Maybe [CocoLicense],+ cocoImages :: [CocoImage],+ cocoAnnotations :: [CocoAnnotation],+ cocoCategories :: [CocoCategory]+ }+ deriving (Show, Eq, Generic)++instance FromJSON Coco where+ parseJSON = withObject "coco" $ \o -> do+ cocoInfo <- o .:? "info"+ cocoLicenses <- o .:? "licenses"+ cocoImages <- o .: "images"+ cocoAnnotations <- o .: "annotations"+ cocoCategories <- o .: "categories"+ return Coco {..}++instance ToJSON Coco where+ toJSON Coco {..} =+ object+ [ "info" .= cocoInfo,+ "licenses" .= cocoLicenses,+ "images" .= cocoImages,+ "annotations" .= cocoAnnotations,+ "categories" .= cocoCategories+ ]++-- Coco result format is shown in https://cocodataset.org/#format-results .++data CocoResult = CocoResult+ { cocoResultImageId :: ImageId,+ cocoResultCategory :: CategoryId,+ cocoResultScore :: Score,+ cocoResultBbox :: CoCoBoundingBox+ }+ deriving (Show, Eq, Generic)++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"+ return CocoResult {..}++instance ToJSON CocoResult where+ toJSON CocoResult {..} =+ object+ [ "image_id" .= cocoResultImageId,+ "category_id" .= cocoResultCategory,+ "score" .= cocoResultScore,+ "bbox" .= case cocoResultBbox of CoCoBoundingBox (x, y, w, h) -> [x, y, w, h]+ ]++readCoco :: FilePath -> IO Coco+readCoco path = do+ json <- BS.readFile path+ case eitherDecode json of+ Left err -> error err+ Right coco -> return coco++writeCoco :: FilePath -> Coco -> IO ()+writeCoco path coco = BS.writeFile path $ encode coco++readCocoResult :: FilePath -> IO [CocoResult]+readCocoResult path = do+ json <- BS.readFile path+ case eitherDecode json of+ Left err -> error err+ Right coco -> return coco++writeCocoResult :: FilePath -> [CocoResult] -> IO ()+writeCocoResult path coco = BS.writeFile path $ encode coco++getCocoImageByFileName :: Coco -> FilePath -> Maybe (CocoImage, [CocoAnnotation])+getCocoImageByFileName coco fileName =+ case filter (\CocoImage {..} -> T.unpack cocoImageFileName == fileName) $ cocoImages coco of+ [] -> Nothing+ (x : _) ->+ let annotations = filter (\CocoAnnotation {..} -> cocoAnnotationImageId == cocoImageId x) $ cocoAnnotations coco+ in Just (x, annotations)++getCocoResultByFileName :: Coco -> [CocoResult] -> FilePath -> Maybe (CocoImage, [CocoResult])+getCocoResultByFileName coco cocoResult fileName =+ case filter (\CocoImage {..} -> T.unpack cocoImageFileName == fileName) $ cocoImages coco of+ [] -> Nothing+ (x : _) ->+ let results = filter (\CocoResult {..} -> cocoResultImageId == cocoImageId x) cocoResult+ in Just (x, results)++toCocoImageMap :: Coco -> Map.Map ImageId CocoImage+toCocoImageMap coco = Map.fromList $ map (\image -> (cocoImageId image, image)) $ cocoImages coco++toCocoAnnotationMap :: Coco -> Map.Map ImageId [CocoAnnotation]+toCocoAnnotationMap coco = Map.fromListWith (++) $ map (\annotation -> (cocoAnnotationImageId annotation, [annotation])) $ cocoAnnotations coco++toCategoryMap :: Coco -> Map.Map CategoryId CocoCategory+toCategoryMap coco = Map.fromList $ map (\category -> (cocoCategoryId category, category)) $ cocoCategories coco++toFilepathMap :: Coco -> Map.Map ImageId FilePath+toFilepathMap coco = Map.fromList $ map (\image -> (cocoImageId image, T.unpack $ cocoImageFileName image)) $ cocoImages coco++-- | Convert coco to image id map+-- | Key is image file name, and value is a list of image id+toImageId :: Coco -> Map.Map FilePath [ImageId]+toImageId coco = Map.fromListWith (++) $ map (\image -> (T.unpack $ cocoImageFileName image, [cocoImageId image])) $ cocoImages coco++toCocoResultMap :: [CocoResult] -> Map.Map ImageId [CocoResult]+toCocoResultMap cocoResult = Map.fromListWith (++) $ map (\result -> (cocoResultImageId result, [result])) cocoResult++data CocoMap = CocoMap+ { cocoMapImageId :: Map.Map FilePath [ImageId],+ cocoMapCocoImage :: Map.Map ImageId CocoImage,+ cocoMapCocoAnnotation :: Map.Map ImageId [CocoAnnotation],+ cocoMapCocoCategory :: Map.Map CategoryId CocoCategory,+ cocoMapCocoResult :: Map.Map ImageId [CocoResult],+ cocoMapFilepath :: Map.Map ImageId FilePath,+ cocoMapImageIds :: [ImageId],+ cocoMapCategoryIds :: [CategoryId]+ }+ deriving (Show, Eq, Generic)++toCocoMap :: Coco -> [CocoResult] -> CocoMap+toCocoMap coco cocoResult =+ let cocoMapImageId = toImageId coco+ cocoMapCocoImage = toCocoImageMap coco+ cocoMapCocoAnnotation = toCocoAnnotationMap coco+ cocoMapCocoCategory = toCategoryMap coco+ cocoMapCocoResult = toCocoResultMap cocoResult+ cocoMapFilepath = toFilepathMap coco+ cocoMapImageIds = map (\CocoImage {..} -> cocoImageId) $ cocoImages coco+ cocoMapCategoryIds = map (\CocoCategory {..} -> cocoCategoryId) $ cocoCategories coco+ in CocoMap {..}
+ src/RiskWeaver/Metric.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}++module RiskWeaver.Metric where++import Data.List (maximumBy, sort, sortBy)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import RiskWeaver.Format.Coco+import GHC.Generics++newtype IOU = IOU Double deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic)++newtype IOG = IOG Double deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Generic)++data Dt a+ = Dt a+ | DtBackground+ deriving (Show, Eq, Ord)++data Gt a+ = Gt a+ | GtBackground+ deriving (Show, Eq, Ord)++iou :: CoCoBoundingBox -> CoCoBoundingBox -> IOU+iou (CoCoBoundingBox (x1, y1, w1, h1)) (CoCoBoundingBox (x2, y2, w2, h2)) =+ let x1' = x1 + w1+ y1' = y1 + h1+ x2' = x2 + w2+ y2' = y2 + h2+ x = max x1 x2+ y = max y1 y2+ x' = min x1' x2'+ y' = min y1' y2'+ intersection = max 0 (x' - x) * max 0 (y' - y)+ union = w1 * h1 + w2 * h2 - intersection+ in IOU $ intersection / union++iog :: CoCoBoundingBox -> CoCoBoundingBox -> IOG+iog (CoCoBoundingBox (x1, y1, w1, h1)) (CoCoBoundingBox (x2, y2, w2, h2)) =+ let x1' = x1 + w1+ y1' = y1 + h1+ x2' = x2 + w2+ y2' = y2 + h2+ x = max x1 x2+ y = max y1 y2+ x' = min x1' x2'+ y' = min y1' y2'+ intersection = max 0 (x' - x) * max 0 (y' - y)+ groundTruth = w1 * h1+ in IOG $ intersection / groundTruth++-- | Calculate TP or FP+-- | TP = true positive+-- | FP = false positive+-- | 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.+ detections :: [CocoResult] =+ case Map.lookup imageId cocoMapCocoResult of+ Nothing -> []+ Just results ->+ sortBy (\cocoResult1 cocoResult2 -> compare (cocoResultScore cocoResult2) (cocoResultScore cocoResult1)) $+ filter (\result -> cocoResultCategory result == categoryId) results+ groundTruthsList :: [CocoAnnotation] =+ filter (\annotation -> cocoAnnotationCategory annotation == categoryId) $+ fromMaybe [] $+ Map.lookup imageId cocoMapCocoAnnotation+ groundTruths :: Map.Map Int CocoAnnotation =+ Map.fromList $ zip [0 ..] groundTruthsList+ numOfGroundTruths = Map.size groundTruths+ getGTWithMaxScore :: CocoResult -> Map.Map Int CocoAnnotation -> Maybe (Int, CocoAnnotation, IOU)+ getGTWithMaxScore cocoResult gts =+ if Map.size gts == 0+ then Nothing+ else+ 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'+ 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+ 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)]+ precisionRecallCurve [] _ _ = []+ precisionRecallCurve (x : xs) accTps accNum =+ (precision, recall) : 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+ ap :: [(Double, Double)] -> (Double, Double) -> Double+ ap [] (maxPrecision, maxRecall) = maxPrecision * maxRecall+ ap ((precision, recall) : xs) (maxPrecision, maxRecall) =+ if precision - maxPrecision > 0+ then maxPrecision * (maxRecall - recall) + ap xs (precision, recall)+ else ap xs (maxPrecision, maxRecall)+ in case precisionRecallCurve' of+ [] -> 0+ (x : xs) -> ap xs x++mAP :: CocoMap -> IOU -> (Double, [(CategoryId, Double)])+mAP cocoMap@CocoMap {..} iouThresh =+ let categoryIds = cocoMapCategoryIds+ aps = map (\categoryId -> apForCategory cocoMap categoryId iouThresh) categoryIds+ 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++confusionMatrix :: CocoMap -> IOU -> Score -> ConfusionMatrix+confusionMatrix cocoMap@CocoMap {..} iouThresh scoreThresh =+ foldl (<>) (ConfusionMatrix Map.empty Map.empty cocoMapCategoryIds) $+ map (confusionMatrixForImage cocoMap iouThresh scoreThresh) cocoMapImageIds++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
+ test/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."