gdritter repos fulcrum / 0bf1428
factored out fulcrum into its own package Getty Ritter 9 years ago
7 changed file(s) with 423 addition(s) and 0 deletion(s). Collapse all Expand all
+48
-0
Data/Analysis/Fulcrum/Abstract.hs less more
1 module Data.Analysis.Fulcrum.Abstract
2 ( Typeable
3 , Abstract
4 , makeAbs
5 , absShow
6 , absShowS
7 ) where
8
9 import Data.Dynamic
10 import Data.Monoid
11 import Data.Typeable (Typeable)
12
13 data Abstract = Abstract
14 { absVal :: Dynamic
15 , absEq :: Abstract -> Bool
16 , absCmp :: Abstract -> Ordering
17 , absStr :: String
18 }
19
20 absShowS :: [Abstract] -> String
21 absShowS [] = ""
22 absShowS [x] = absShow x
23 absShowS (x:xs) = absShow x ++ "," ++ absShowS xs
24
25 absShow :: Abstract -> String
26 absShow = absStr
27
28 over :: Typeable a => (a -> b) -> b -> Dynamic -> b
29 over op def dyn
30 | Just x <- fromDynamic dyn = op x
31 | otherwise = def
32
33 -- | Oftentimes we want to compare two things without knowing that
34 -- they're even the same type. We can wrap them in this and
35 -- ensure that those operations are still possible.
36 makeAbs :: (Typeable t, Ord t, Show t) => t -> Abstract
37 makeAbs x = Abstract
38 { absVal = toDyn x
39 , absEq = doEq . absVal
40 , absCmp = doCmp . absVal
41 , absStr = show x
42 } where doEq = over (== x) False
43 doCmp y = over (compare x) (cmpTyp y) y
44 cmpTyp y = dynTypeRep (toDyn x) `compare` dynTypeRep y
45
46 instance Eq Abstract where a == b = a `absEq` b
47 instance Show Abstract where show a = "Abstract(" ++ absStr a ++ ")"
48 instance Ord Abstract where a `compare` b = a `absCmp` b
+174
-0
Data/Analysis/Fulcrum/Analysis.hs less more
1 {-# LANGUAGE ExistentialQuantification #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE DeriveFunctor #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7
8 module Data.Analysis.Fulcrum.Analysis
9 ( module Data.Analysis.Fulcrum.Abstract
10
11 , runPlanToMap
12
13 , Merge
14 , Plan(..)
15 , defaultPlan
16 , Select
17 , slName
18 , Result
19
20 , select
21 , getUniqVals
22 , getAxisValues
23 , getLineValues
24 , validRowValue
25
26 , opBy
27 , divBy
28 ) where
29
30 import Control.Applicative ((<$>))
31 import Control.Arrow (second)
32 import Control.Lens
33 import Data.Dynamic
34 import Data.Maybe (catMaybes)
35 import Data.Monoid (Monoid(..), (<>))
36 import Data.List (nub, sort, find)
37 import Data.Map.Strict (Map, fromList)
38
39 import Data.Analysis.Fulcrum.Abstract
40
41 type AVal = [Abstract]
42
43 -- | A merge function is anything that takes several
44 -- rows and merges them to a single value.
45 type Merge r = [r] -> r
46
47 -- | A selector returns a list of abstract values, and is used
48 -- for extracting from heterogeneous data.
49 data Select r = Select
50 { _slLens :: Getter r AVal
51 , _slName :: String
52 }
53
54 slName :: Select r -> String
55 slName = _slName
56
57 -- | Turn a getter for a specific type into a getter of a generic
58 -- value (so we can compare possibly across types)
59 select :: (Typeable a, Ord a, Show a) => Getter r a -> String -> Select r
60 select l s = Select (l.to go) s
61 where go x = [makeAbs x]
62
63 -- | A convenience function to combine strings with commas
64 comma :: String -> String -> String
65 comma x "" = x
66 comma "" y = y
67 comma x y = x <> "," <> y
68
69 instance Monoid (Select r) where
70 mappend (Select l ln) (Select r rn) =
71 Select (to (\ x -> x^.l <> x^.r)) (comma ln rn)
72 mempty = Select (to (const mempty)) ""
73
74 -- | A convenience function to run a selector over data
75 extract :: Select r -> r -> AVal
76 extract (Select l _) r = (r^.l)
77
78 -- | A plan describes how to go from a dataset of type [row]
79 -- and arrive at a Result map
80 data Plan row focus = Plan
81 { planFocus :: Getter row focus -- ^ The final dependent variable
82 , planFCName :: String -- ^ The name of the dependent variable
83 , planName :: String -- ^ The name of the plan
84 , planFilters :: row -> Bool -- ^ select which rows to keep
85 , planMaps :: row -> row -- ^ transform them somehow
86 , planAxis :: Select row -- ^ select an independent variable
87 , planLines :: Select row -- ^ select sets of interesting data
88 , planMerge :: Merge focus -- ^ join the resulting rows together
89 , planLinAxis :: Bool -- ^ true if the axis is linear
90 }
91
92 defaultPlan :: Plan a a
93 defaultPlan = Plan
94 { planFocus = error "undefined focus"
95 , planFCName = "undefined"
96 , planName = "default plan"
97 , planFilters = const True
98 , planMaps = id
99 , planAxis = mempty
100 , planLines = mempty
101 , planMerge = error "undefined merge"
102 , planLinAxis = True
103 }
104
105 -- | The result of a plan is always going to be a map from
106 -- (abstract but comparable) keys to some kind of result
107 -- value.
108 type Result r = Map (AVal, AVal) r
109
110 -- | Given a selector and a list of rows, groups into sub-lists that
111 -- share a common value for the selector.
112 groupOn :: (Select r) -> [r] -> [[r]]
113 groupOn l rs = [ filter (go v) rs | v <- getUniqVals l rs ]
114 where go v r = extract l r == v
115
116 -- | Extract every unique value that appears in the data
117 getUniqVals :: (Select r) -> [r] -> [AVal]
118 getUniqVals l rs = sort (nub (map (extract l) rs))
119
120 -- | Merge the focused value using the merge function
121 combine :: Getter r f -> Merge f -> [r] -> f
122 combine focus merge = merge . map (^.focus)
123
124 -- | Group into a map based on the axis values and lines
125 group :: Select r -> Select r -> [r] -> [((AVal, AVal), [r])]
126 group l a rs =
127 [ ((extract a (head r), extract l (head r)), r)
128 | r <- groupOn (l <> a) rs
129 ]
130
131 -- | Execute a given plan on a set of data
132 runPlanToMap :: Plan r f -> [r] -> Result f
133 runPlanToMap p@(Plan { .. }) rawData =
134 fromList $ map (second (combine planFocus planMerge))
135 $ group planLines planAxis
136 $ map planMaps
137 $ filter planFilters
138 $ rawData
139
140 -- | A convenience function for writing maps over rows
141 opBy :: (a -> a -> a) -> Setter' r a -> Getter r a -> Getter r a -> r -> r
142 opBy op t l r x = set t ((x^.l) `op` (x^.r)) x
143
144 -- | A specialized convenience function for normalizing a given value
145 -- by another by division
146 divBy :: Lens' r Double -> Getter r Double -> r -> r
147 divBy l = opBy (/) l l
148
149 -- | A specialized convenience function for normalizing a given value
150 -- by another using an nth root
151 rootBy :: Lens' r Double -> Getter r Double -> r -> r
152 rootBy l = undefined
153
154 -- | Get the unique points to graph along the X axis
155 getAxisValues :: Plan r f -> [r] -> [AVal]
156 getAxisValues (Plan { .. }) rows =
157 getUniqVals planAxis (filter planFilters rows)
158
159 -- | Get the human-readable name of the X axis variable
160 getAxisName :: Plan r f -> String
161 getAxisName = slName . planAxis
162
163 -- | Get the unique field values which determine the set of lines to produce
164 getLineValues :: Plan r f -> [r] -> [AVal]
165 getLineValues (Plan { .. }) rows =
166 getUniqVals planLines (filter planFilters rows)
167
168 -- | Get the human-readable name of the lines
169 getLineName :: Plan r f -> String
170 getLineName = slName . planLines
171
172 -- | Determine whether a given (abstract) value appears in the data set
173 validRowValue :: Select r -> [r] -> AVal -> Bool
174 validRowValue l rs a = any (== a) (getUniqVals l rs)
+122
-0
Data/Analysis/Fulcrum/Plot.hs less more
1 {-# LANGUAGE RecordWildCards #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE ParallelListComp #-}
4
5 module Data.Analysis.Fulcrum.Plot (doPlot, doLogPlot) where
6
7 import Control.Lens ((^.), (.~), (&), set, Lens', to)
8 import Data.Colour (opaque, Colour)
9 import Data.Colour.Names
10 import Data.Default.Class (def)
11 import Data.Map.Strict ((!), member)
12 import Data.Maybe (fromJust)
13 import Data.Monoid ((<>))
14 import Graphics.Rendering.Chart
15 import Math.Statistics (stddev, average)
16
17 import Data.Analysis.Fulcrum.Analysis
18
19 type AVal = [Abstract]
20
21 colors :: [Colour Double]
22 colors = cycle [ blue, red, green, orange, purple, yellow ]
23
24 plotLayout :: PlotValue b => Plan r f -> [r] -> Layout Int b
25 plotLayout plan@(Plan { .. }) rows
26 = layout_background .~ solidFillStyle (opaque white)
27 $ layout_x_axis.laxis_generate .~
28 autoIndexAxis (map absShowS axisNames)
29 $ layout_y_axis.laxis_title .~ planFCName
30 $ layout_x_axis.laxis_title .~ slName planAxis
31 $ layout_title .~ planName
32 $ setLayoutForeground (opaque black)
33 $ def
34 where axisNames = getAxisValues plan rows
35
36 plotLines :: (RealFloat f, PlotValue g) =>
37 Bool -> (Result f) -> String -> [(Int, AVal)]
38 -> AVal -> Colour Double -> (f -> g) -> [PlotLines Int g]
39 plotLines True vals axisTitle axisNames ln c conv =
40 [ plot_lines_style .~ lineStyle 4 c
41 $ plot_lines_values .~
42 [ [ (idx, conv (vals ! (ax, ln)))
43 | (idx, ax) <- axisNames
44 , (ax, ln) `member` vals
45 , not (isNaN (vals ! (ax, ln))) ] ]
46 $ plot_lines_title .~ axisTitle
47 $ def
48 ]
49 plotLines False _ _ _ _ _ _ = []
50
51 plotDots :: (RealFloat f, PlotValue g) => Result f -> [(Int, AVal)] -> AVal
52 -> Colour Double -> (f -> g) -> PlotPoints Int g
53 plotDots vals axisNames ln color conv
54 = plot_points_style .~ filledCircles 5 (opaque color)
55 $ plot_points_values .~
56 [ (idx, conv (vals ! (ax, ln)))
57 | (idx, ax) <- axisNames
58 , (ax, ln) `member` vals
59 , not (isNaN (vals ! (ax, ln))) ]
60 $ def
61
62 plotStds :: (RealFloat f) => Result f -> Result f ->
63 [(Int, AVal)] -> AVal -> Colour Double -> PlotErrBars Int f
64 plotStds avgs stds axisNames ln color
65 = plot_errbars_line_style .~ lineStyle 1 color
66 $ plot_errbars_values .~
67 [ symErrPoint idx (avgs ! (ax, ln)) 0 (stds ! (ax, ln))
68 | (idx, ax) <- axisNames
69 , (ax, ln) `member` avgs
70 , not (isNaN (stds ! (ax, ln)))
71 , not (isNaN (avgs ! (ax, ln))) ]
72 $ def
73
74 doLogPlot :: Plan r Double -> [r] -> Renderable ()
75 doLogPlot plan@(Plan { .. }) rows =
76 toRenderable $ layout_plots .~ map toPlot (concat plots) <>
77 map toPlot dots
78 $ plotLayout plan rows
79 where plots = [ plotLines planLinAxis avgs "" axisNums ln c LogValue
80 | ln <- lineNames
81 | c <- colors
82 ]
83 dots = [ plotDots avgs axisNums ln c LogValue
84 | ln <- lineNames
85 | c <- colors
86 ]
87 lineNames = getLineValues plan rows
88 axisNames = getAxisValues plan rows
89 runPlan m = runPlanToMap (plan { planMerge = m })
90 avgs = runPlan average rows
91 axisNums = zip [(0::Int)..] axisNames
92
93 doPlot :: (RealFloat f, PlotValue f) => Plan r f -> [r] -> Renderable ()
94 doPlot plan@(Plan { .. }) rows =
95 toRenderable $ layout_plots .~ map toPlot bars <>
96 map toPlot (concat plots) <>
97 map toPlot dots
98 $ plotLayout plan rows
99 where plots = [ plotLines planLinAxis avgs "" axisNums ln c id
100 | ln <- lineNames
101 | c <- colors
102 ]
103 dots = [ plotDots avgs axisNums ln c id
104 | ln <- lineNames
105 | c <- colors
106 ]
107 bars = [ plotStds avgs stds axisNums ln c
108 | ln <- lineNames
109 | c <- colors
110 ]
111 lineNames = getLineValues plan rows
112 axisNames = getAxisValues plan rows
113 runPlan m = runPlanToMap (plan { planMerge = m })
114 avgs = runPlan average rows
115 stds = runPlan stddev rows
116 axisNums = zip [(0::Int)..] axisNames
117
118 lineStyle :: Double -> Colour Double -> LineStyle
119 lineStyle n c
120 = line_width .~ n
121 $ line_color .~ opaque c
122 $ def
+42
-0
Data/Analysis/Fulcrum/Pretty.hs less more
1 module Data.Analysis.Fulcrum.Pretty (showResults) where
2
3 import Data.List (nub)
4 import Data.Map.Strict (Map)
5 import qualified Data.Map.Strict as M
6
7 import Data.Analysis.Fulcrum.Analysis
8
9 showResults :: Show a => Result a -> String
10 showResults = showTable . tabulate
11
12 tabulate :: Show a => Result a -> [[String]]
13 tabulate res =
14 [ [""] ++ map absShowS cols ] ++
15 [ absShowS r :
16 [ maybe "" show (M.lookup (c,r) res)
17 | c <- cols
18 ]
19 | r <- rows
20 ]
21 where rows = nub $ map snd (M.keys res)
22 cols = nub $ map fst (M.keys res)
23
24 strJoin :: String -> [String] -> String
25 strJoin c [] = []
26 strJoin c (x:[]) = x
27 strJoin c (x:xs) = x ++ c ++ strJoin c xs
28
29 rowJoin :: [String] -> String
30 rowJoin = strJoin " | "
31
32 showTable :: [[String]] -> String
33 showTable tab = unlines $ map rowJoin $ map padRow tab
34 where sizes :: [Int]
35 sizes = [ maximum (map (length . (!! n)) tab)
36 | n <- [0..(length (head tab))-1]
37 ]
38 pad len str =
39 let diff = len - length str
40 in str ++ (take diff $ repeat ' ')
41 padRow :: [String] -> [String]
42 padRow = zipWith pad sizes
+7
-0
Data/Analysis/Fulcrum.hs less more
1 module Data.Analysis.Fulcrum
2 ( module Data.Analysis.Fulcrum.Analysis
3 , module Data.Analysis.Fulcrum.Pretty
4 ) where
5
6 import Data.Analysis.Fulcrum.Analysis
7 import Data.Analysis.Fulcrum.Pretty
+0
-0
LICENSE less more
(New empty file)
+30
-0
fulcrum.cabal less more
1 name: fulcrum
2 version: 0.1.0.1
3 license-file: LICENSE
4 author: Getty Ritter
5 maintainer: gdritter@galois.com
6 build-type: Simple
7 cabal-version: >=1.10
8
9 library
10 exposed-modules: Data.Analysis.Fulcrum,
11 Data.Analysis.Fulcrum.Abstract,
12 Data.Analysis.Fulcrum.Analysis,
13 Data.Analysis.Fulcrum.Plot
14 Data.Analysis.Fulcrum.Pretty
15 other-extensions: TemplateHaskell,
16 RankNTypes,
17 ExistentialQuantification,
18 DeriveFunctor,
19 RecordWildCards,
20 ScopedTypeVariables,
21 ParallelListComp
22 build-depends: base >=4.6 && <4.7,
23 lens >=4.1 && <4.2,
24 containers >=0.5 && <0.6,
25 Chart >=1.2 && <1.3,
26 Chart-cairo >=1.2 && <1.3,
27 colour >=2.3 && <2.4,
28 data-default-class >=0.0 && <0.1,
29 hstats >=0.3 && <0.4
30 default-language: Haskell2010