Remove some warnings
This commit is contained in:
parent
dbe4783d3c
commit
a7e731a0f8
@ -5,14 +5,10 @@ module GEval.Clippings
|
|||||||
|
|
||||||
import Data.Attoparsec.Text
|
import Data.Attoparsec.Text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
import Control.Applicative
|
|
||||||
import Control.Exception
|
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.List (unfoldr)
|
import Data.List (unfoldr)
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
|
|
||||||
import Debug.Trace
|
|
||||||
|
|
||||||
import GEval.Common
|
import GEval.Common
|
||||||
import GEval.PrecisionRecall (maxMatch)
|
import GEval.PrecisionRecall (maxMatch)
|
||||||
|
|
||||||
@ -49,7 +45,7 @@ lineClippingsParser = sepByWhitespaces clippingParser
|
|||||||
clippingParser :: Parser Clipping
|
clippingParser :: Parser Clipping
|
||||||
clippingParser = do
|
clippingParser = do
|
||||||
pageNo <- PageNumber <$> decimal
|
pageNo <- PageNumber <$> decimal
|
||||||
char '/'
|
_ <- char '/'
|
||||||
rectangle <- rectangleParser
|
rectangle <- rectangleParser
|
||||||
return $ Clipping pageNo rectangle
|
return $ Clipping pageNo rectangle
|
||||||
|
|
||||||
@ -59,9 +55,9 @@ lineClippingSpecsParser = sepByWhitespaces clippingSpecParser
|
|||||||
clippingSpecParser :: Parser ClippingSpec
|
clippingSpecParser :: Parser ClippingSpec
|
||||||
clippingSpecParser = do
|
clippingSpecParser = do
|
||||||
pageNo <- PageNumber <$> decimal
|
pageNo <- PageNumber <$> decimal
|
||||||
char '/'
|
_ <- char '/'
|
||||||
rectangle <- rectangleParser
|
rectangle <- rectangleParser
|
||||||
char '/'
|
_ <- char '/'
|
||||||
margin <- decimal
|
margin <- decimal
|
||||||
return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle)
|
return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle)
|
||||||
|
|
||||||
@ -73,7 +69,7 @@ labeledClippingParser =
|
|||||||
clippingWithLabelParser :: Parser LabeledClipping
|
clippingWithLabelParser :: Parser LabeledClipping
|
||||||
clippingWithLabelParser = do
|
clippingWithLabelParser = do
|
||||||
label <- takeWhile1 (\c -> not (isSpace c) && c /= ':')
|
label <- takeWhile1 (\c -> not (isSpace c) && c /= ':')
|
||||||
string ":"
|
_ <- string ":"
|
||||||
clipping <- clippingParser
|
clipping <- clippingParser
|
||||||
return $ LabeledClipping (Just label) clipping
|
return $ LabeledClipping (Just label) clipping
|
||||||
|
|
||||||
@ -90,8 +86,7 @@ smallerRectangle margin (Rectangle (Point x0 y0) (Point x1 y1)) =
|
|||||||
Rectangle (Point (x0 + margin) (y0 + margin))
|
Rectangle (Point (x0 + margin) (y0 + margin))
|
||||||
(Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin))
|
(Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin))
|
||||||
|
|
||||||
|
nonNegativeDiff :: (Ord p, Num p) => p -> p -> p
|
||||||
|
|
||||||
nonNegativeDiff x y
|
nonNegativeDiff x y
|
||||||
| x < y = 0
|
| x < y = 0
|
||||||
| otherwise = x - y
|
| otherwise = x - y
|
||||||
@ -99,11 +94,11 @@ nonNegativeDiff x y
|
|||||||
rectangleParser :: Parser Rectangle
|
rectangleParser :: Parser Rectangle
|
||||||
rectangleParser = do
|
rectangleParser = do
|
||||||
x0 <- decimal
|
x0 <- decimal
|
||||||
char ','
|
_ <- char ','
|
||||||
y0 <- decimal
|
y0 <- decimal
|
||||||
char ','
|
_ <- char ','
|
||||||
x1 <- decimal
|
x1 <- decimal
|
||||||
char ','
|
_ <- char ','
|
||||||
y1 <- decimal
|
y1 <- decimal
|
||||||
if x1 < x0 || y1 < y0
|
if x1 < x0 || y1 < y0
|
||||||
then fail "wrong coordinates"
|
then fail "wrong coordinates"
|
||||||
@ -128,7 +123,7 @@ coveredBy clippingsA clippingsB = sum
|
|||||||
step ([], _) = Nothing
|
step ([], _) = Nothing
|
||||||
step (firstA:restA, b) = Just (result, (newA ++ restA, newB))
|
step (firstA:restA, b) = Just (result, (newA ++ restA, newB))
|
||||||
where (result, newA, newB) = step' firstA b
|
where (result, newA, newB) = step' firstA b
|
||||||
step' rectA [] = (Nothing, [], [])
|
step' _ [] = (Nothing, [], [])
|
||||||
step' a (firstB:restB) = case partitionClippings a firstB of
|
step' a (firstB:restB) = case partitionClippings a firstB of
|
||||||
Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB)
|
Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB)
|
||||||
Nothing -> let
|
Nothing -> let
|
||||||
@ -160,8 +155,9 @@ getLeftovers (Rectangle (Point x0 y0) (Point x1 y1))
|
|||||||
Rectangle (Point x0 (y1 + 1)) (Point x1 y1'),
|
Rectangle (Point x0 (y1 + 1)) (Point x1 y1'),
|
||||||
Rectangle (Point x0' y0') (Point (x0 - 1) y1'),
|
Rectangle (Point x0' y0') (Point (x0 - 1) y1'),
|
||||||
Rectangle (Point (x1 + 1) y0') (Point x1' y1')]
|
Rectangle (Point (x1 + 1) y0') (Point x1' y1')]
|
||||||
where validRectangle (Rectangle (Point x0 y0) (Point x1 y1)) = x0 <= x1 && y0 <= y1
|
where validRectangle (Rectangle (Point x0'' y0'') (Point x1'' y1'')) = x0'' <= x1'' && y0'' <= y1''
|
||||||
|
|
||||||
|
clippEUMatchStep :: ([ClippingSpec], [Clipping]) -> (Int, Int, Int)
|
||||||
clippEUMatchStep (clippingSpecs, clippings) = (maxMatch matchClippingToSpec clippingSpecs clippings,
|
clippEUMatchStep (clippingSpecs, clippings) = (maxMatch matchClippingToSpec clippingSpecs clippings,
|
||||||
Prelude.length clippingSpecs,
|
Prelude.length clippingSpecs,
|
||||||
Prelude.length clippings)
|
Prelude.length clippings)
|
||||||
|
@ -10,13 +10,10 @@ module GEval.PrecisionRecall(calculateMAPForOneResult,
|
|||||||
countFragFolder, fMeasureOnSeparatedCounts, f1MeasureOnSeparatedCounts)
|
countFragFolder, fMeasureOnSeparatedCounts, f1MeasureOnSeparatedCounts)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Debug.Trace
|
|
||||||
|
|
||||||
import GEval.Common
|
import GEval.Common
|
||||||
import GEval.Probability
|
import GEval.Probability
|
||||||
|
|
||||||
import Data.Graph.Inductive
|
import Data.Graph.Inductive
|
||||||
import Data.Graph.Inductive.Query.MaxFlow
|
|
||||||
|
|
||||||
import Data.List (find, foldl', nub)
|
import Data.List (find, foldl', nub)
|
||||||
|
|
||||||
@ -28,10 +25,10 @@ import qualified Data.HashMap.Strict as M
|
|||||||
calculateMAPForOneResult :: (Eq a) => [a] -> [a] -> Double
|
calculateMAPForOneResult :: (Eq a) => [a] -> [a] -> Double
|
||||||
calculateMAPForOneResult expected got = precisionSum / fromIntegral (length expected)
|
calculateMAPForOneResult expected got = precisionSum / fromIntegral (length expected)
|
||||||
where (_::Int, _, precisionSum) = calculateMAPForOneResultCore expected (nub got)
|
where (_::Int, _, precisionSum) = calculateMAPForOneResultCore expected (nub got)
|
||||||
calculateMAPForOneResultCore expected got = foldl' (oneMAPStep expected) (0, 0, 0.0) got
|
calculateMAPForOneResultCore expected' got' = foldl' (oneMAPStep expected') (0, 0, 0.0) got'
|
||||||
oneMAPStep expected (gotCount, allCount, precisionSum) gotItem
|
oneMAPStep expected' (gotCount, allCount, precisionSum') gotItem
|
||||||
| gotItem `elem` expected = (newGotCount, newAllCount, precisionSum + (newGotCount /. newAllCount))
|
| gotItem `elem` expected' = (newGotCount, newAllCount, precisionSum' + (newGotCount /. newAllCount))
|
||||||
| otherwise = (gotCount, newAllCount, precisionSum)
|
| otherwise = (gotCount, newAllCount, precisionSum')
|
||||||
where newGotCount = gotCount + 1
|
where newGotCount = gotCount + 1
|
||||||
newAllCount = allCount + 1
|
newAllCount = allCount + 1
|
||||||
|
|
||||||
@ -53,7 +50,7 @@ fMeasure beta matchingFun expected got = weightedHarmonicMean beta p r
|
|||||||
weightedHarmonicMean :: Double -> Double -> Double -> Double
|
weightedHarmonicMean :: Double -> Double -> Double -> Double
|
||||||
weightedHarmonicMean beta x y =
|
weightedHarmonicMean beta x y =
|
||||||
(1 + betaSquared) * x * y `safeDoubleDiv` (betaSquared * x + y)
|
(1 + betaSquared) * x * y `safeDoubleDiv` (betaSquared * x + y)
|
||||||
where betaSquared = beta ^ 2
|
where betaSquared = beta ^ (2 :: Int)
|
||||||
|
|
||||||
f2MeasureOnCounts :: ConvertibleToDouble n => (n, Int, Int) -> Double
|
f2MeasureOnCounts :: ConvertibleToDouble n => (n, Int, Int) -> Double
|
||||||
f2MeasureOnCounts = fMeasureOnCounts 2.0
|
f2MeasureOnCounts = fMeasureOnCounts 2.0
|
||||||
@ -127,9 +124,9 @@ maxMatchOnOrdered laterThan expected got =
|
|||||||
-- counting maximum match with maximum bipartite matching
|
-- counting maximum match with maximum bipartite matching
|
||||||
-- (we build an auxiliary graph and do a max-flow on this)
|
-- (we build an auxiliary graph and do a max-flow on this)
|
||||||
maxMatch :: (a -> b -> Bool) -> [a] -> [b] -> Int
|
maxMatch :: (a -> b -> Bool) -> [a] -> [b] -> Int
|
||||||
maxMatch matchFun expected got = mf
|
maxMatch matchFun expected got = mfVal
|
||||||
where (b, e, g) = buildGraph matchFun expected got
|
where (b, e, g) = buildGraph matchFun expected got
|
||||||
mf = maxFlow g (fst b) (fst e)
|
mfVal = maxFlow g (fst b) (fst e)
|
||||||
|
|
||||||
buildGraph :: (a -> b -> Bool) -> [a] -> [b] -> (LNode Int, LNode Int, Gr Int Int)
|
buildGraph :: (a -> b -> Bool) -> [a] -> [b] -> (LNode Int, LNode Int, Gr Int Int)
|
||||||
buildGraph matchFun expected got = (b, e, g)
|
buildGraph matchFun expected got = (b, e, g)
|
||||||
@ -138,7 +135,7 @@ buildGraph matchFun expected got = (b, e, g)
|
|||||||
run empty $
|
run empty $
|
||||||
do b <- insMapNodeM 0
|
do b <- insMapNodeM 0
|
||||||
e <- insMapNodeM 1
|
e <- insMapNodeM 1
|
||||||
mapM insMapNodeM [2..1+(length expected)+(length got)]
|
_ <- mapM insMapNodeM [2..1+(length expected)+(length got)]
|
||||||
insMapEdgesM $ map (\n -> (0, n, 1)) expectedIxs
|
insMapEdgesM $ map (\n -> (0, n, 1)) expectedIxs
|
||||||
insMapEdgesM $ map (\m -> (m, 1, 1)) gotIxs
|
insMapEdgesM $ map (\m -> (m, 1, 1)) gotIxs
|
||||||
insMapEdgesM $ map (\(n,m) -> (n, m, 1))
|
insMapEdgesM $ map (\(n,m) -> (n, m, 1))
|
||||||
@ -172,7 +169,7 @@ getProbabilisticCounts (expected, got) = (results, (map getProbabilityAsDouble g
|
|||||||
length expected)
|
length expected)
|
||||||
where gotMass = sum $ map (\(i, j) -> (matchScore (expected !! (i - 1)) (got !! (j - 1))) * (getProbabilityAsDouble (got !! (j - 1)))) matching
|
where gotMass = sum $ map (\(i, j) -> (matchScore (expected !! (i - 1)) (got !! (j - 1))) * (getProbabilityAsDouble (got !! (j - 1)))) matching
|
||||||
results = map findResult [1..(length got)]
|
results = map findResult [1..(length got)]
|
||||||
findResult j = case find (\(i, j') -> j' == j) $ matching of
|
findResult j = case find (\(_, j') -> j' == j) $ matching of
|
||||||
Just (i, _) -> matchScore (expected !! (i - 1)) (got !! (j - 1))
|
Just (i, _) -> matchScore (expected !! (i - 1)) (got !! (j - 1))
|
||||||
Nothing -> 0.0
|
Nothing -> 0.0
|
||||||
(matching, _) = weightedMaxMatching matchScore expected got
|
(matching, _) = weightedMaxMatching matchScore expected got
|
||||||
|
Loading…
Reference in New Issue
Block a user