diff --git a/amby.cabal b/amby.cabal --- a/amby.cabal +++ b/amby.cabal @@ -1,5 +1,5 @@ name: amby -version: 0.3.1 +version: 0.3.2 synopsis: Statistical data visualization description: <> <> @@ -28,26 +28,35 @@ category: Graphics build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.10.2 +tested-with: GHC==8.0.1, GHC==7.10.3 +Data-files: data/seaborn_tips.csv library hs-source-dirs: src exposed-modules: Amby - other-modules: Amby.Types - , Amby.Style - , Amby.Theme - , Amby.Numeric - , Amby.Plot - , Amby.Display + other-modules: Amby.BoxPlot + , Amby.Categorical , Amby.Compatibility.HistogramPlot , Amby.Compatibility.HistogramNumeric + , Amby.Display + , Amby.FactorPlot + , Amby.Numeric + , Amby.Plot + , Amby.Style + , Amby.Theme + , Amby.Types + , Amby.Util + , Paths_amby build-depends: base >= 4.7 && < 5 , data-default-class , Chart-cairo , Chart-diagrams , Chart + , text , vector , vector-algorithms + , containers + , extra , statistics , colour , scientific @@ -58,9 +67,14 @@ , process , exceptions , data-default + , mwc-random + , foldl + , datasets + , cassava + , bytestring + -- 'Lens' package used as dependency of 'Chart' , lens - , mwc-random ghc-options: -Wall -fno-warn-orphans default-language: Haskell2010 @@ -75,6 +89,15 @@ , tasty-hunit , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark amby-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: base + , amby + , statistics default-language: Haskell2010 source-repository head diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,7 @@ +import qualified Statistics.Distribution.Normal as Stats +import qualified Amby as Am + +main :: IO () +main = do + z <- Am.random Stats.standard 10000 + Am.save $ Am.rugPlot' z diff --git a/data/seaborn_tips.csv b/data/seaborn_tips.csv new file mode 100644 --- /dev/null +++ b/data/seaborn_tips.csv @@ -0,0 +1,245 @@ +"total_bill","tip","sex","smoker","day","time","size" +16.99,1.01,"Female","No","Sun","Dinner",2 +10.34,1.66,"Male","No","Sun","Dinner",3 +21.01,3.5,"Male","No","Sun","Dinner",3 +23.68,3.31,"Male","No","Sun","Dinner",2 +24.59,3.61,"Female","No","Sun","Dinner",4 +25.29,4.71,"Male","No","Sun","Dinner",4 +8.77,2,"Male","No","Sun","Dinner",2 +26.88,3.12,"Male","No","Sun","Dinner",4 +15.04,1.96,"Male","No","Sun","Dinner",2 +14.78,3.23,"Male","No","Sun","Dinner",2 +10.27,1.71,"Male","No","Sun","Dinner",2 +35.26,5,"Female","No","Sun","Dinner",4 +15.42,1.57,"Male","No","Sun","Dinner",2 +18.43,3,"Male","No","Sun","Dinner",4 +14.83,3.02,"Female","No","Sun","Dinner",2 +21.58,3.92,"Male","No","Sun","Dinner",2 +10.33,1.67,"Female","No","Sun","Dinner",3 +16.29,3.71,"Male","No","Sun","Dinner",3 +16.97,3.5,"Female","No","Sun","Dinner",3 +20.65,3.35,"Male","No","Sat","Dinner",3 +17.92,4.08,"Male","No","Sat","Dinner",2 +20.29,2.75,"Female","No","Sat","Dinner",2 +15.77,2.23,"Female","No","Sat","Dinner",2 +39.42,7.58,"Male","No","Sat","Dinner",4 +19.82,3.18,"Male","No","Sat","Dinner",2 +17.81,2.34,"Male","No","Sat","Dinner",4 +13.37,2,"Male","No","Sat","Dinner",2 +12.69,2,"Male","No","Sat","Dinner",2 +21.7,4.3,"Male","No","Sat","Dinner",2 +19.65,3,"Female","No","Sat","Dinner",2 +9.55,1.45,"Male","No","Sat","Dinner",2 +18.35,2.5,"Male","No","Sat","Dinner",4 +15.06,3,"Female","No","Sat","Dinner",2 +20.69,2.45,"Female","No","Sat","Dinner",4 +17.78,3.27,"Male","No","Sat","Dinner",2 +24.06,3.6,"Male","No","Sat","Dinner",3 +16.31,2,"Male","No","Sat","Dinner",3 +16.93,3.07,"Female","No","Sat","Dinner",3 +18.69,2.31,"Male","No","Sat","Dinner",3 +31.27,5,"Male","No","Sat","Dinner",3 +16.04,2.24,"Male","No","Sat","Dinner",3 +17.46,2.54,"Male","No","Sun","Dinner",2 +13.94,3.06,"Male","No","Sun","Dinner",2 +9.68,1.32,"Male","No","Sun","Dinner",2 +30.4,5.6,"Male","No","Sun","Dinner",4 +18.29,3,"Male","No","Sun","Dinner",2 +22.23,5,"Male","No","Sun","Dinner",2 +32.4,6,"Male","No","Sun","Dinner",4 +28.55,2.05,"Male","No","Sun","Dinner",3 +18.04,3,"Male","No","Sun","Dinner",2 +12.54,2.5,"Male","No","Sun","Dinner",2 +10.29,2.6,"Female","No","Sun","Dinner",2 +34.81,5.2,"Female","No","Sun","Dinner",4 +9.94,1.56,"Male","No","Sun","Dinner",2 +25.56,4.34,"Male","No","Sun","Dinner",4 +19.49,3.51,"Male","No","Sun","Dinner",2 +38.01,3,"Male","Yes","Sat","Dinner",4 +26.41,1.5,"Female","No","Sat","Dinner",2 +11.24,1.76,"Male","Yes","Sat","Dinner",2 +48.27,6.73,"Male","No","Sat","Dinner",4 +20.29,3.21,"Male","Yes","Sat","Dinner",2 +13.81,2,"Male","Yes","Sat","Dinner",2 +11.02,1.98,"Male","Yes","Sat","Dinner",2 +18.29,3.76,"Male","Yes","Sat","Dinner",4 +17.59,2.64,"Male","No","Sat","Dinner",3 +20.08,3.15,"Male","No","Sat","Dinner",3 +16.45,2.47,"Female","No","Sat","Dinner",2 +3.07,1,"Female","Yes","Sat","Dinner",1 +20.23,2.01,"Male","No","Sat","Dinner",2 +15.01,2.09,"Male","Yes","Sat","Dinner",2 +12.02,1.97,"Male","No","Sat","Dinner",2 +17.07,3,"Female","No","Sat","Dinner",3 +26.86,3.14,"Female","Yes","Sat","Dinner",2 +25.28,5,"Female","Yes","Sat","Dinner",2 +14.73,2.2,"Female","No","Sat","Dinner",2 +10.51,1.25,"Male","No","Sat","Dinner",2 +17.92,3.08,"Male","Yes","Sat","Dinner",2 +27.2,4,"Male","No","Thur","Lunch",4 +22.76,3,"Male","No","Thur","Lunch",2 +17.29,2.71,"Male","No","Thur","Lunch",2 +19.44,3,"Male","Yes","Thur","Lunch",2 +16.66,3.4,"Male","No","Thur","Lunch",2 +10.07,1.83,"Female","No","Thur","Lunch",1 +32.68,5,"Male","Yes","Thur","Lunch",2 +15.98,2.03,"Male","No","Thur","Lunch",2 +34.83,5.17,"Female","No","Thur","Lunch",4 +13.03,2,"Male","No","Thur","Lunch",2 +18.28,4,"Male","No","Thur","Lunch",2 +24.71,5.85,"Male","No","Thur","Lunch",2 +21.16,3,"Male","No","Thur","Lunch",2 +28.97,3,"Male","Yes","Fri","Dinner",2 +22.49,3.5,"Male","No","Fri","Dinner",2 +5.75,1,"Female","Yes","Fri","Dinner",2 +16.32,4.3,"Female","Yes","Fri","Dinner",2 +22.75,3.25,"Female","No","Fri","Dinner",2 +40.17,4.73,"Male","Yes","Fri","Dinner",4 +27.28,4,"Male","Yes","Fri","Dinner",2 +12.03,1.5,"Male","Yes","Fri","Dinner",2 +21.01,3,"Male","Yes","Fri","Dinner",2 +12.46,1.5,"Male","No","Fri","Dinner",2 +11.35,2.5,"Female","Yes","Fri","Dinner",2 +15.38,3,"Female","Yes","Fri","Dinner",2 +44.3,2.5,"Female","Yes","Sat","Dinner",3 +22.42,3.48,"Female","Yes","Sat","Dinner",2 +20.92,4.08,"Female","No","Sat","Dinner",2 +15.36,1.64,"Male","Yes","Sat","Dinner",2 +20.49,4.06,"Male","Yes","Sat","Dinner",2 +25.21,4.29,"Male","Yes","Sat","Dinner",2 +18.24,3.76,"Male","No","Sat","Dinner",2 +14.31,4,"Female","Yes","Sat","Dinner",2 +14,3,"Male","No","Sat","Dinner",2 +7.25,1,"Female","No","Sat","Dinner",1 +38.07,4,"Male","No","Sun","Dinner",3 +23.95,2.55,"Male","No","Sun","Dinner",2 +25.71,4,"Female","No","Sun","Dinner",3 +17.31,3.5,"Female","No","Sun","Dinner",2 +29.93,5.07,"Male","No","Sun","Dinner",4 +10.65,1.5,"Female","No","Thur","Lunch",2 +12.43,1.8,"Female","No","Thur","Lunch",2 +24.08,2.92,"Female","No","Thur","Lunch",4 +11.69,2.31,"Male","No","Thur","Lunch",2 +13.42,1.68,"Female","No","Thur","Lunch",2 +14.26,2.5,"Male","No","Thur","Lunch",2 +15.95,2,"Male","No","Thur","Lunch",2 +12.48,2.52,"Female","No","Thur","Lunch",2 +29.8,4.2,"Female","No","Thur","Lunch",6 +8.52,1.48,"Male","No","Thur","Lunch",2 +14.52,2,"Female","No","Thur","Lunch",2 +11.38,2,"Female","No","Thur","Lunch",2 +22.82,2.18,"Male","No","Thur","Lunch",3 +19.08,1.5,"Male","No","Thur","Lunch",2 +20.27,2.83,"Female","No","Thur","Lunch",2 +11.17,1.5,"Female","No","Thur","Lunch",2 +12.26,2,"Female","No","Thur","Lunch",2 +18.26,3.25,"Female","No","Thur","Lunch",2 +8.51,1.25,"Female","No","Thur","Lunch",2 +10.33,2,"Female","No","Thur","Lunch",2 +14.15,2,"Female","No","Thur","Lunch",2 +16,2,"Male","Yes","Thur","Lunch",2 +13.16,2.75,"Female","No","Thur","Lunch",2 +17.47,3.5,"Female","No","Thur","Lunch",2 +34.3,6.7,"Male","No","Thur","Lunch",6 +41.19,5,"Male","No","Thur","Lunch",5 +27.05,5,"Female","No","Thur","Lunch",6 +16.43,2.3,"Female","No","Thur","Lunch",2 +8.35,1.5,"Female","No","Thur","Lunch",2 +18.64,1.36,"Female","No","Thur","Lunch",3 +11.87,1.63,"Female","No","Thur","Lunch",2 +9.78,1.73,"Male","No","Thur","Lunch",2 +7.51,2,"Male","No","Thur","Lunch",2 +14.07,2.5,"Male","No","Sun","Dinner",2 +13.13,2,"Male","No","Sun","Dinner",2 +17.26,2.74,"Male","No","Sun","Dinner",3 +24.55,2,"Male","No","Sun","Dinner",4 +19.77,2,"Male","No","Sun","Dinner",4 +29.85,5.14,"Female","No","Sun","Dinner",5 +48.17,5,"Male","No","Sun","Dinner",6 +25,3.75,"Female","No","Sun","Dinner",4 +13.39,2.61,"Female","No","Sun","Dinner",2 +16.49,2,"Male","No","Sun","Dinner",4 +21.5,3.5,"Male","No","Sun","Dinner",4 +12.66,2.5,"Male","No","Sun","Dinner",2 +16.21,2,"Female","No","Sun","Dinner",3 +13.81,2,"Male","No","Sun","Dinner",2 +17.51,3,"Female","Yes","Sun","Dinner",2 +24.52,3.48,"Male","No","Sun","Dinner",3 +20.76,2.24,"Male","No","Sun","Dinner",2 +31.71,4.5,"Male","No","Sun","Dinner",4 +10.59,1.61,"Female","Yes","Sat","Dinner",2 +10.63,2,"Female","Yes","Sat","Dinner",2 +50.81,10,"Male","Yes","Sat","Dinner",3 +15.81,3.16,"Male","Yes","Sat","Dinner",2 +7.25,5.15,"Male","Yes","Sun","Dinner",2 +31.85,3.18,"Male","Yes","Sun","Dinner",2 +16.82,4,"Male","Yes","Sun","Dinner",2 +32.9,3.11,"Male","Yes","Sun","Dinner",2 +17.89,2,"Male","Yes","Sun","Dinner",2 +14.48,2,"Male","Yes","Sun","Dinner",2 +9.6,4,"Female","Yes","Sun","Dinner",2 +34.63,3.55,"Male","Yes","Sun","Dinner",2 +34.65,3.68,"Male","Yes","Sun","Dinner",4 +23.33,5.65,"Male","Yes","Sun","Dinner",2 +45.35,3.5,"Male","Yes","Sun","Dinner",3 +23.17,6.5,"Male","Yes","Sun","Dinner",4 +40.55,3,"Male","Yes","Sun","Dinner",2 +20.69,5,"Male","No","Sun","Dinner",5 +20.9,3.5,"Female","Yes","Sun","Dinner",3 +30.46,2,"Male","Yes","Sun","Dinner",5 +18.15,3.5,"Female","Yes","Sun","Dinner",3 +23.1,4,"Male","Yes","Sun","Dinner",3 +15.69,1.5,"Male","Yes","Sun","Dinner",2 +19.81,4.19,"Female","Yes","Thur","Lunch",2 +28.44,2.56,"Male","Yes","Thur","Lunch",2 +15.48,2.02,"Male","Yes","Thur","Lunch",2 +16.58,4,"Male","Yes","Thur","Lunch",2 +7.56,1.44,"Male","No","Thur","Lunch",2 +10.34,2,"Male","Yes","Thur","Lunch",2 +43.11,5,"Female","Yes","Thur","Lunch",4 +13,2,"Female","Yes","Thur","Lunch",2 +13.51,2,"Male","Yes","Thur","Lunch",2 +18.71,4,"Male","Yes","Thur","Lunch",3 +12.74,2.01,"Female","Yes","Thur","Lunch",2 +13,2,"Female","Yes","Thur","Lunch",2 +16.4,2.5,"Female","Yes","Thur","Lunch",2 +20.53,4,"Male","Yes","Thur","Lunch",4 +16.47,3.23,"Female","Yes","Thur","Lunch",3 +26.59,3.41,"Male","Yes","Sat","Dinner",3 +38.73,3,"Male","Yes","Sat","Dinner",4 +24.27,2.03,"Male","Yes","Sat","Dinner",2 +12.76,2.23,"Female","Yes","Sat","Dinner",2 +30.06,2,"Male","Yes","Sat","Dinner",3 +25.89,5.16,"Male","Yes","Sat","Dinner",4 +48.33,9,"Male","No","Sat","Dinner",4 +13.27,2.5,"Female","Yes","Sat","Dinner",2 +28.17,6.5,"Female","Yes","Sat","Dinner",3 +12.9,1.1,"Female","Yes","Sat","Dinner",2 +28.15,3,"Male","Yes","Sat","Dinner",5 +11.59,1.5,"Male","Yes","Sat","Dinner",2 +7.74,1.44,"Male","Yes","Sat","Dinner",2 +30.14,3.09,"Female","Yes","Sat","Dinner",4 +12.16,2.2,"Male","Yes","Fri","Lunch",2 +13.42,3.48,"Female","Yes","Fri","Lunch",2 +8.58,1.92,"Male","Yes","Fri","Lunch",1 +15.98,3,"Female","No","Fri","Lunch",3 +13.42,1.58,"Male","Yes","Fri","Lunch",2 +16.27,2.5,"Female","Yes","Fri","Lunch",2 +10.09,2,"Female","Yes","Fri","Lunch",2 +20.45,3,"Male","No","Sat","Dinner",4 +13.28,2.72,"Male","No","Sat","Dinner",2 +22.12,2.88,"Female","Yes","Sat","Dinner",2 +24.01,2,"Male","Yes","Sat","Dinner",4 +15.69,3,"Male","Yes","Sat","Dinner",3 +11.61,3.39,"Male","No","Sat","Dinner",2 +10.77,1.47,"Male","No","Sat","Dinner",2 +15.53,3,"Male","Yes","Sat","Dinner",2 +10.07,1.25,"Male","No","Sat","Dinner",2 +12.6,1,"Male","Yes","Sat","Dinner",2 +32.83,1.17,"Male","Yes","Sat","Dinner",2 +35.83,4.67,"Female","No","Sat","Dinner",3 +29.03,5.92,"Male","No","Sat","Dinner",3 +27.18,2,"Female","Yes","Sat","Dinner",2 +22.67,2,"Male","Yes","Sat","Dinner",2 +17.82,1.75,"Male","No","Sat","Dinner",2 +18.78,3,"Female","No","Thur","Dinner",2 diff --git a/src/Amby.hs b/src/Amby.hs --- a/src/Amby.hs +++ b/src/Amby.hs @@ -7,10 +7,12 @@ module Amby ( -- * Modules - module Amby.Theme + module Amby.Categorical + , module Amby.Theme , module Amby.Numeric , module Amby.Types , module Amby.Plot + , module Amby.Util -- * Lens operators , (.=) @@ -18,8 +20,10 @@ import Graphics.Rendering.Chart.Easy ((.=)) +import Amby.Categorical import Amby.Types import Amby.Numeric import Amby.Theme import Amby.Plot import Amby.Display () +import Amby.Util diff --git a/src/Amby/BoxPlot.hs b/src/Amby/BoxPlot.hs new file mode 100644 --- /dev/null +++ b/src/Amby/BoxPlot.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE FlexibleContexts #-} +module Amby.BoxPlot + ( boxPlotVec + , boxPlotVec' + ) where + +import Control.Arrow ((***)) +import Control.Monad +import Control.Monad.State +import qualified Data.List as L +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U + +import Control.Lens +import Data.Colour (transparent, opaque) +import qualified Data.Colour as Colour +import Data.Colour.SRGB (sRGB) +import Graphics.Rendering.Chart.Easy (Layout, EC) +import Graphics.Rendering.Chart.Easy as Chart + +import Amby.Categorical +import Amby.Types +import Amby.Theme +import Amby.Style (categoricalAxisData, scaledAxisCustom) +import Amby.Numeric + +boxPlotVec :: (G.Vector v Double, G.Vector v (Double, Double)) + => v Double -> State BoxPlotOpts () -> AmbyChart () +boxPlotVec xs optsState = do + layout <- takeLayout + putLayout $ do + layout + palette <- Chart.liftCState $ do + cs <- use Chart.colors + return cs + drawBoxPlot palette xs opts + where + opts = execState optsState def + +boxPlotVec' :: (G.Vector v Double, G.Vector v (Double, Double)) + => v Double -> AmbyChart () +boxPlotVec' xs = boxPlotVec xs $ return () + +drawBoxPlot :: (G.Vector v Double, G.Vector v (Double, Double)) + => Palette -> v Double -> BoxPlotOpts + -> EC (Layout Double Double) () +drawBoxPlot palette xs opts + -- Boxplot for univariate distribution + | opts ^. facL == DefaultCategory = do + drawUnivariate (head catPalette) lineGray startPos barHeight xs "" opts + + -- Axis changes + -- TODO: Replace manual axis ranges with better automatic scaling + axisGetter . Chart.laxis_generate .= scaledAxisCustom def + ( mkAxisTuple + (startPos - (barHeight / 2) - (1/8) * barHeight) + (startPos + (barHeight / 2) + (1/8) * barHeight) + ) + axisGetter . Chart.laxis_override .= categoricalAxisData [] + axisGetter . Chart.laxis_title .= (opts ^. facLabel) + datAxisGetter . Chart.laxis_title .= (opts ^. datLabel) + -- TODO: Chart does not give a way to add a title to a legend, or + -- to change positon of legend + + -- Boxplot against categorical data + | opts ^. hueL == DefaultCategory = do + -- group data + let groups = groupByCategory (G.toList xs) (opts ^. facL) + + -- draw data + forM_ (zip3 groups catPalette [0..]) $ \(g, c, i) -> + drawUnivariate c lineGray (facMidPos i) barHeight (U.fromList g) "" opts + + -- Axis changes + axisGetter . Chart.laxis_generate .= scaledAxisCustom def + ( mkAxisTuple + (facMidPos (nFacs - 1) - facMargin - (barHeight / 2)) + (startPos + (barHeight / 2) + facMargin) + ) + axisGetter . Chart.laxis_override .= categoricalAxisData facLabelPos + axisGetter . Chart.laxis_title .= (opts ^. facLabel) + datAxisGetter . Chart.laxis_title .= (opts ^. datLabel) + + -- Boxplot against two categories + | otherwise = do + -- group data + let groups = groupByCategory (G.toList xs) facs + hueGroups = groupByCategory (getCategoryList hues) facs + + -- draw data + forM_ (zip3 groups hueGroups [0..]) $ \(facData, hueData, i) -> + forM_ (zip3 (getCategoryOrder hues) catPalette [0..]) $ \(hueVal, c, j) -> do + let hueMask = map (== hueVal) hueData + drawData = U.fromList $ filterMask facData hueMask + l = if i == 0 && (opts ^. hueLegend) + then getCategoryLabelFromVal hues hueVal + else "" + drawUnivariate c lineGray (hueMidPos i j) barHeight drawData l opts + + -- Axis changes + axisGetter . Chart.laxis_generate .= scaledAxisCustom def + ( mkAxisTuple + (hueMidPos (nFacs - 1) (nHues - 1) - (barHeight / 2) - hueMargin) + (startPos + (barHeight / 2) + hueMargin) + ) + axisGetter . Chart.laxis_override .= categoricalAxisData hueLabelPos + axisGetter . Chart.laxis_title .= (opts ^. facLabel) + datAxisGetter . Chart.laxis_title .= (opts ^. datLabel) + where + facs = opts ^. facL + hues = opts ^. hueL + facLabels = getCategoryLabels facs + nFacs = catSize facs + nHues = catSize hues + cUser = opts ^. color + sat = opts ^. saturation + (catPalette, lineGray) = getCategoricalPalette palette cUser nFacs nHues sat + + mkAxisTuple x y = if opts ^. axis == XAxis + then (x, y) + else (abs y, abs x) + mkLabelTuple x s = if opts ^. axis == XAxis + then (x, s) + else (abs x, s) + + barHeight = 1.0 + startPos = -1.0 + + facMidSpacing = barHeight / 4.0 + facMidPos :: Int -> Double + facMidPos i = startPos - (barHeight + facMidSpacing) * fromIntegral i + facMargin = barHeight / 4.0 + facLabelPos = if opts ^. facLegend + then zipWith (\i l -> mkLabelTuple (facMidPos i) l) [0..] facLabels + else [] + + hueMidSpacing = barHeight / 2.0 + hueMargin = barHeight / 2.0 + hueCatSize = fromIntegral nHues * barHeight + hueSpan = (fromIntegral (nHues - 1) * barHeight) / 2 + hueMidPos :: Int -> Int -> Double + hueMidPos i j = + startPos + - (fromIntegral j * barHeight) + - (fromIntegral i * (hueCatSize + hueMidSpacing)) + hueLabelMidPos i = startPos - hueSpan - i * (hueCatSize + hueMidSpacing) + hueLabelPos = if opts ^. facLegend + then zipWith (\i l -> mkLabelTuple (hueLabelMidPos i) l) [0..] facLabels + else [] + + axisGetter = if (opts ^. axis) == XAxis + then Chart.layout_y_axis + else Chart.layout_x_axis + datAxisGetter = if (opts ^. axis) == XAxis + then Chart.layout_x_axis + else Chart.layout_y_axis + +drawUnivariate :: (G.Vector v Double, G.Vector v (Double, Double)) + => AlphaColour Double -> AlphaColour Double + -> Double -> Double -> v Double -> String + -> BoxPlotOpts -> EC (Layout Double Double) () +drawUnivariate c lineGray midY yHeight xs l opts = do + Chart.plot $ return $ Chart.Plot + { _plot_render = if noData then const (return ()) else renderBoxPlot + , _plot_legend = [(l, renderLabel)] + , _plot_all_points = if noData then ([], []) else unzip allPoints + } + Chart.plot $ Chart.liftEC $ do + Chart.plot_points_values .= outlierPts + Chart.plot_points_style . Chart.point_radius .= 4 + Chart.plot_points_style . Chart.point_shape .= Chart.PointShapePolygon 4 True + Chart.plot_points_style . Chart.point_color .= lineGray + where + noData = G.length xs == 0 + whiskLimit = interquartileRange xs * 1.5 + firstQuartile = scoreAtPercentile xs 25 + thirdQuartile = scoreAtPercentile xs 75 + median = scoreAtPercentile xs 50 + startWhiskFoldFn a b = if b < a && b >= firstQuartile - whiskLimit + then b + else a + endWhiskFoldFn a b = if b > a && b <= thirdQuartile + whiskLimit + then b + else a + startWhisk = G.foldl' startWhiskFoldFn firstQuartile xs + endWhisk = G.foldl' endWhiskFoldFn thirdQuartile xs + outliers = G.filter (\x -> x < startWhisk || x > endWhisk) xs + pt x y = if opts ^. axis == XAxis then (x, y) else (-y, x) + yt = midY + (yHeight / 2) + yb = midY - (yHeight / 2) + yt4 = midY + (yHeight / 4) + yb4 = midY - (yHeight / 4) + + outlierPts = G.toList $ G.map (\x -> pt x midY) outliers + + allPoints = + [ pt startWhisk yt4, pt startWhisk yb4, pt startWhisk midY + , pt firstQuartile midY + , pt firstQuartile yt, pt firstQuartile yb, pt median yt, pt median yb + , pt thirdQuartile yt, pt thirdQuartile yb, pt thirdQuartile midY + , pt endWhisk midY, pt endWhisk yt4, pt endWhisk yb4 + ] ++ outlierPts + + renderLabel r@(Rect _ _) = do + Chart.withFillStyle fillStyle $ do + Chart.alignFillPath (Chart.rectPath r) >>= Chart.fillPath + Chart.withLineStyle lineStyle $ do + Chart.alignStrokePath (Chart.rectPath r) >>= Chart.strokePath + where + lineStyle = def + & Chart.line_width .~ (opts ^. linewidth) / 2 + & Chart.line_color .~ lineGray + fillStyle = def & Chart.fill_color .~ c + + renderBoxPlot pmap = do + Chart.withFillStyle fillStyle $ do + Chart.alignFillPath (plotBox pmap) >>= Chart.fillPath + Chart.withLineStyle lineStyle $ do + Chart.alignStrokePath (plotWhiskers pmap) >>= Chart.strokePath + Chart.alignStrokePath (plotBox pmap) >>= Chart.strokePath + where + lineStyle = def + & Chart.line_width .~ (opts ^. linewidth) + & Chart.line_color .~ lineGray + fillStyle = def + & Chart.fill_color .~ Colour.dissolve 0.8 c + + plotWhiskers pmap = + Chart.MoveTo (ptr startWhisk yt4) + $ Chart.LineTo (ptr startWhisk yb4) + $ Chart.MoveTo (ptr startWhisk midY) + $ Chart.LineTo (ptr firstQuartile midY) + $ Chart.MoveTo (ptr thirdQuartile midY) + $ Chart.LineTo (ptr endWhisk midY) + $ Chart.MoveTo (ptr endWhisk yt4) + $ Chart.LineTo (ptr endWhisk yb4) + $ Chart.End + where + ptr x y = pmap $ join (***) Chart.LValue $ pt x y + + plotBox pmap = if firstQuartile == thirdQuartile + then + Chart.MoveTo (ptr firstQuartile yt) + $ Chart.LineTo (ptr firstQuartile yb) + $ Chart.End + else + Chart.MoveTo (ptr median yt) + $ Chart.LineTo (ptr firstQuartile yt) + $ Chart.LineTo (ptr firstQuartile yb) + $ Chart.LineTo (ptr median yb) + $ Chart.LineTo (ptr median yt) + $ Chart.LineTo (ptr thirdQuartile yt) + $ Chart.LineTo (ptr thirdQuartile yb) + $ Chart.LineTo (ptr median yb) + $ Chart.End + where + ptr x y = pmap $ join (***) Chart.LValue $ pt x y + +getCategoricalPalette :: Palette -> AmbyColor -> Int -> Int -> Double + -> (Palette, AlphaColour Double) +getCategoricalPalette palette cUser n nHues sat = (desatColors, lineGray) + where + cUserAlpha = toColour cUser transparent + effN = if nHues > 1 then nHues else n + iniColors + -- Passing specific color + | cUser /= DefaultColor && nHues <= 1 = replicate effN cUserAlpha + | cUser /= DefaultColor = lightPalette cUserAlpha nHues + + -- Using default colors + | (length . L.nub . take effN) palette < effN = + huslPalette n Nothing Nothing (Just 0.7) + | otherwise = take effN palette + desatColors = map (desaturate sat) iniColors + l = (* 0.6) . minimum $ map ((^. _3) . alphaToHsl) desatColors + lineGray = opaque $ sRGB l l l diff --git a/src/Amby/Categorical.hs b/src/Amby/Categorical.hs new file mode 100644 --- /dev/null +++ b/src/Amby/Categorical.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +module Amby.Categorical + ( + -- * Types + Category(..) + + -- * Methods + , toCat + , toCatOrdered + , changeOrder + , getCategoryLabels + , getCategoryLabelFromVal + , getCategoryOrder + , getCategoryList + , catSize + , catValsLength + , filterMask + , groupByCategory + , groupCategoryBy + , getGroupAt + , getGroupWithFilterMask + ) where + +import qualified Data.Foldable as Foldable +import qualified Data.List.Extra as L +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple (swap) + +import Control.Lens +import Safe + +data Category = Category + { _categoryOrder :: [Int] + , _categoryValues :: [Int] + , _categoryTable :: Map Int String + , _categoryGroups :: [[Int]] + } + | DefaultCategory + deriving (Show, Eq) + +-- | Get list of category labels in order. +getCategoryLabels :: Category -> [String] +getCategoryLabels c = map lookupLabel intOrder + where + labelMap = _categoryTable c + intOrder = _categoryOrder c + lookupLabel i = case Map.lookup i labelMap of + Just a -> a + Nothing -> modErr "getCategoryLabels" "Value does not exist in category" + +getCategoryLabelFromVal :: Category -> Int -> String +getCategoryLabelFromVal c i = case Map.lookup i (_categoryTable c) of + Just a -> a + Nothing -> modErr "getCategoryLabelFromVal" "Value does not exist in category" + +getCategoryList :: Category -> [Int] +getCategoryList = _categoryValues + +getCategoryOrder :: Category -> [Int] +getCategoryOrder = _categoryOrder + +-- | Group by category. +-- +-- Examples: +-- +-- >>> groupByCategory [1..5] (toCat [1, 1, 3, 2, 4]) +-- [[1,2],[3],[4],[5]] +groupByCategory :: [a] -> Category -> [[a]] +groupByCategory xs cat + | length xs /= length (getCategoryList cat) = + modErr "groupByCategory" "Can only group data with equivalent sized category" + | otherwise = + map (map fst) + $ L.groupSortOn snd + $ zip xs (_categoryValues cat) + +-- | Group category internally +groupCategoryBy :: Category -> Category -> Category +groupCategoryBy cat grouper = cat + { _categoryGroups = groupByCategory dat grouper + } + where + dat = _categoryValues cat + +getGroupAt :: Category -> Int -> Category +getGroupAt cat i = cat + { _categoryValues = groupValues + } + where + groupValues = getGroupValues cat i + +getGroupWithFilterMask :: Category -> Int -> [Bool] -> Category +getGroupWithFilterMask cat i mask = cat + { _categoryValues = filterMask groupValues mask + } + where + groupValues = getGroupValues cat i + +getGroupValues :: Category -> Int -> [Int] +getGroupValues cat i = groupValues + where + dat = _categoryGroups cat + groupValues = case dat `atMay` i of + Just a -> a + Nothing -> modErr "getGroupAt" ("No group at index: " ++ show i) + +-- | Filter list based on another equal sized list of bools. +-- +-- Examples: +-- +-- >>> filterMask [1..5] [True, False, True, False, False] +-- [1,3] +filterMask :: [a] -> [Bool] -> [a] +filterMask xs ts + | length xs /= length ts = + modErr "filterMask" "mask length must match data length." + | otherwise = (map fst . filter snd . zip xs) ts + +-- | Find number of distinct elements in a category. +-- +-- Examples: +-- +-- >>> catSize $ toCat ["dog", "cat", "dog"] +-- 2 +catSize :: Category -> Int +catSize DefaultCategory = 1 +catSize cat = Map.size (_categoryTable cat) + +-- | Find the number of elements in a category. +catValsLength :: Category -> Int +catValsLength c = length $ getCategoryList c + +-- | Convert 'Foldable' into a 'Category'. +toCat :: (Foldable f, Eq a, Show a) => f a -> Category +toCat f = listToCat list order + where + list = Foldable.toList f + order = L.nub list + +toCatOrdered :: (Foldable f, Eq a, Show a) => f a -> f a -> Category +toCatOrdered f order = listToCat (Foldable.toList f) (Foldable.toList order) + +changeOrder :: (Foldable f, Show a) => Category -> f a -> Category +changeOrder cat order = cat + { _categoryOrder = newOrder + } + where + currOrder = _categoryOrder cat + intMap = _categoryTable cat + nameMap = (`map` currOrder) $ \i -> case Map.lookup i intMap of + Nothing -> modErr "changeOrder" "Invalid map key" + Just a -> (a, i) + newOrder = (`map` Foldable.toList order) $ \s -> + case lookup (mkDisplayString s) nameMap of + Nothing -> modErr "changeOrder" "Invalid string key" + Just a -> a + +listToCat :: (Eq a, Show a) => [a] -> [a] -> Category +listToCat xs order + | L.length (L.nub order) /= L.length order = + modErr "listToCat" "Order cannot contain duplicates" + | otherwise = Category + { _categoryOrder = map snd orderedPairs + , _categoryValues = map replaceWithIdx xs + , _categoryTable = map swap orderedPairs + & mapped . _2 %~ mkDisplayString + & Map.fromList + , _categoryGroups = [] + } + where + orderedPairs = zip order [0..] + replaceWithIdx x = case lookup x orderedPairs of + Just a -> a + Nothing -> modErr "listToCat" "No idx created for category value" + +mkDisplayString :: Show a => a -> String +mkDisplayString = filter (/= '"') . show + +modErr :: String -> String -> a +modErr f err = error + $ showString "Amby.Container." + $ showString f + $ showString ": " err diff --git a/src/Amby/Compatibility/HistogramPlot.hs b/src/Amby/Compatibility/HistogramPlot.hs --- a/src/Amby/Compatibility/HistogramPlot.hs +++ b/src/Amby/Compatibility/HistogramPlot.hs @@ -1,9 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} +-------------------------------------------- +-- TODO: Replace HistogramPlot and HistogramNumeric with optimized versions. +-------------------------------------------- module Amby.Compatibility.HistogramPlot ( -- * Histograms PlotHist (..) + , BackendProgram , histToPlot , defaultPlotHist , defaultFloatPlotHist diff --git a/src/Amby/Display.hs b/src/Amby/Display.hs --- a/src/Amby/Display.hs +++ b/src/Amby/Display.hs @@ -24,7 +24,10 @@ instance {-# OVERLAPPING #-} Display (EC (Layout Double Double) ()) where display a = saveAndDisplayEC a -saveAndDisplay :: AmbyChart () -> DisplayText +instance {-# OVERLAPPING #-} Display (AmbyGrid ()) where + display a = saveAndDisplay a + +saveAndDisplay :: Saveable s => s -> DisplayText saveAndDisplay chart = saveAndDisplayIO $ do Plot.save chart @@ -47,4 +50,3 @@ return $ mkDt "Could not find imgcat executable." | otherwise = return $ mkDt "Unknown display error." - diff --git a/src/Amby/FactorPlot.hs b/src/Amby/FactorPlot.hs new file mode 100644 --- /dev/null +++ b/src/Amby/FactorPlot.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +module Amby.FactorPlot + ( factorPlotVec + ) where + +import Control.Lens +import Control.Monad.State +import Data.Default (def) +import qualified Data.Vector as V + +import qualified Graphics.Rendering.Chart.Grid as Chart +import Safe + +import Amby.BoxPlot +import Amby.Categorical +import Amby.Theme +import Amby.Types + +factorPlotVec :: V.Vector Double -> State FactorPlotOpts () -> AmbyGrid () +factorPlotVec xs optsState + -- Single plot + | rows == DefaultCategory && cols == DefaultCategory = do + activeTheme <- takeGridTheme + ambyChart <- case opts ^. kind of + Box -> return $ do + theme activeTheme + boxPlotVec xs $ do + facL .= (opts ^. facL) + hueL .= (opts ^. hueL) + color .= opts ^. color + saturation .= opts ^. saturation + axis .= opts ^. axis + facLabel .= opts ^. facLabel + datLabel .= opts ^. datLabel + setGrid $ chartToGrid ambyChart + + -- Row chart + | rows /= DefaultCategory && cols == DefaultCategory = + drawThirdFactor xs rows Chart.aboveN (catSize rows) 1 (opts ^. rowLabel) opts + + -- Col chart + | rows == DefaultCategory && cols /= DefaultCategory = do + drawThirdFactor xs cols Chart.besideN 1 (catSize cols) (opts ^. colLabel) opts + + -- Row and col chart + | otherwise = + drawFourthFactor xs rows cols opts + where + cols = opts ^. colL + rows = opts ^. rowL + opts = execState optsState def + +drawThirdFactor :: V.Vector Double -> Category + -> ([ChartGrid] -> ChartGrid) -> Int -> Int -> String + -> FactorPlotOpts -> AmbyGrid () +drawThirdFactor xs grouper gridGrouper nRows nCols gLabel opts = do + let cats = opts ^. facL + hues = opts ^. hueL + datGroups = groupByCategory (V.toList xs) grouper + catGroups = cats `groupCategoryBy` grouper + hueGroups = hues `groupCategoryBy` grouper + factorOrder = getCategoryOrder grouper + plotKind = opts ^. kind + drawAxis = opts ^. axis + activeTheme <- takeGridTheme + setGrid + $ gridGrouper + $ (`map` zip factorOrder [0..]) + $ \(factorVal, i) -> do + let datGroup = case datGroups `atMay` i of + Just a -> V.fromList a + Nothing -> modErr "drawThirdFactor" $ "No group at index: " ++ show i + case plotKind of + Box -> chartToGrid $ do + theme activeTheme + boxPlotVec datGroup $ do + facL .= catGroups `getGroupAt` i + hueL .= hueGroups `getGroupAt` i + facLegend .= if nCols > 1 + then i == 0 || drawAxis == YAxis + else i == nRows - 1 || drawAxis == XAxis + hueLegend .= if nCols > 1 + then i == 0 + else i == nRows - 1 + color .= opts ^. color + saturation .= opts ^. saturation + axis .= opts ^. axis + facLabel .= + if (drawAxis == XAxis && nCols > 1 && i == 0) + || (drawAxis == XAxis && nRows > 1) + || (drawAxis == YAxis && nCols > 1) + || (drawAxis == YAxis && nRows > 1 && i == nRows - 1) + then opts ^. facLabel + else "" + datLabel .= + if (drawAxis == XAxis && nCols > 1) + || (drawAxis == XAxis && nRows > 1 && i == nRows - 1) + || (drawAxis == YAxis && nCols > 1 && i == 0) + || (drawAxis == YAxis && nRows > 1) + then opts ^. datLabel + else "" + title + $ mkGridLabel gLabel + ++ getCategoryLabelFromVal grouper factorVal + gridScale (fromIntegral nCols, fromIntegral nRows) + +drawFourthFactor :: V.Vector Double -> Category -> Category -> FactorPlotOpts + -> AmbyGrid () +drawFourthFactor xs rows cols opts = do + activeTheme <- takeGridTheme + setGrid + $ Chart.aboveN + $ (`map` zip rowOrder [0..]) + $ \rowIdx -> + Chart.besideN + $ (`map` zip colOrder [0..]) $ \colIdx -> + drawGridCell rowIdx colIdx activeTheme + gridScale (fromIntegral nCols, fromIntegral nRows) + where + cats = opts ^. facL + hues = opts ^. hueL + datGroups = groupByCategory (V.toList xs) rows + catGroups = cats `groupCategoryBy` rows + hueGroups = hues `groupCategoryBy` rows + colGroups = cols `groupCategoryBy` rows + rowOrder = getCategoryOrder rows + colOrder = getCategoryOrder cols + nRows = length rowOrder + nCols = length colOrder + plotKind = opts ^. kind + rLabel = opts ^. rowLabel + cLabel = opts ^. colLabel + drawAxis = opts ^. axis + + drawGridCell :: (Int, Int) -> (Int, Int) -> Theme -> ChartGrid + drawGridCell (rowVal, i) (colVal, j) activeTheme = do + let rowColGroup = colGroups `getGroupAt` i + colMask = map (== colVal) (getCategoryList rowColGroup) + let rowDatGroup = case datGroups `atMay` i of + Nothing -> modErr "drawFourthFactor" $ "No group at index: " ++ show i + Just a -> V.fromList $ filterMask a colMask + rowCatGroup = getGroupWithFilterMask catGroups i colMask + rowHueGroup = getGroupWithFilterMask hueGroups i colMask + + case plotKind of + Box -> chartToGrid $ do + theme activeTheme + boxPlotVec rowDatGroup $ do + facL .= rowCatGroup + hueL .= rowHueGroup + facLegend .= if drawAxis == XAxis + then j == 0 + else i == nRows - 1 + hueLegend .= (j == 0 && i == nRows - 1) + color .= opts ^. color + saturation .= opts ^. saturation + axis .= opts ^. axis + facLabel .= + if (j == 0 && drawAxis == XAxis) + || (i == nRows - 1 && drawAxis == YAxis) + then opts ^. facLabel + else "" + datLabel .= + if (i == nRows - 1 && drawAxis == XAxis) + || (j == 0 && drawAxis == YAxis) + then opts ^. datLabel + else "" + title + $ mkGridLabel rLabel + ++ getCategoryLabelFromVal rows rowVal + ++ " | " + ++ mkGridLabel cLabel + ++ getCategoryLabelFromVal cols colVal + +mkGridLabel :: String -> String +mkGridLabel s = if null s + then s + else s ++ " = " + +modErr :: String -> String -> a +modErr f err = error + $ showString "Amby.FactorPlot." + $ showString f + $ showString ": " err diff --git a/src/Amby/Numeric.hs b/src/Amby/Numeric.hs --- a/src/Amby/Numeric.hs +++ b/src/Amby/Numeric.hs @@ -23,13 +23,12 @@ ) where -import Data.Vector.Generic ((!)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector as V -import qualified Data.Vector.Algorithms.Intro as V import Statistics.Distribution +import qualified Statistics.Quantile as Stats import System.Random.MWC (withSystemRandom, asGenST) -- $setup @@ -86,30 +85,11 @@ -- -- >>> scoreAtPercentile a 50 -- 49.5 -scoreAtPercentile :: (G.Vector v Double) => v Double -> Double -> Double +scoreAtPercentile :: (G.Vector v Double) => v Double -> Int -> Double scoreAtPercentile xs p - | n == 0 = modErr "scoreAtPercentile" "Percentile sample size is 0" - | p < 0 || p > 100 = modErr "scoreAtPercentile" "Percentile must be in [0, 100]" - | otherwise = (getScore . G.modify V.sort) xs - where - n = G.length xs - idx = (p / 100) * fromIntegral (n - 1) - i = floor idx - j = ceiling idx - - isInt :: Double -> Bool - isInt a = fromIntegral (round a :: Int) == a - - interop :: (G.Vector v Double) => v Double -> Double - interop vec = - (vec ! i) * (fromIntegral j - idx) + - (vec ! j) * (idx - fromIntegral i) - - getScore vec = if isInt idx - then vec ! i - else interop vec -{-# SPECIALIZE scoreAtPercentile :: U.Vector Double -> Double -> Double #-} -{-# SPECIALIZE scoreAtPercentile :: V.Vector Double -> Double -> Double #-} + | G.length xs == 0 = + modErr "scoreAtPercentile" "Cannot find percentile of empyt list" + | otherwise = Stats.weightedAvg p 100 xs -- | Calculate the interquartile range. -- @@ -140,4 +120,5 @@ modErr :: String -> String -> a modErr f err = error $ showString "Amby.Numeric." - $ showString f err + $ showString f + $ showString ": " err diff --git a/src/Amby/Plot.hs b/src/Amby/Plot.hs --- a/src/Amby/Plot.hs +++ b/src/Amby/Plot.hs @@ -8,6 +8,7 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} module Amby.Plot ( getEC + , getRenderable , save , saveSvg @@ -28,7 +29,7 @@ import Control.Lens import Data.Colour as Colour import Data.Default.Class -import Graphics.Rendering.Chart.Easy (Layout, EC) +import Graphics.Rendering.Chart.Easy (Layout, EC, Renderable, LayoutPick) import qualified Graphics.Rendering.Chart.Easy as Chart import qualified Graphics.Rendering.Chart.Backend.Cairo as Cairo import qualified Graphics.Rendering.Chart.Backend.Diagrams as Diagrams @@ -36,7 +37,9 @@ import qualified Statistics.Sample.KernelDensity.Simple as Stats import qualified Statistics.Sample as Stats +import Amby.BoxPlot import Amby.Compatibility.HistogramPlot +import Amby.FactorPlot import Amby.Numeric import Amby.Theme (toColour) import Amby.Types @@ -47,6 +50,7 @@ instance AmbyContainer (V.Vector Double) where type Value (V.Vector Double) = Double + plot = plotVec plot' = plotVec' plotEq = plotEqVec @@ -57,9 +61,13 @@ kdePlot' = kdePlotVec' rugPlot = rugPlotVec rugPlot' = rugPlotVec' + boxPlot = boxPlotVec + boxPlot' = boxPlotVec' + factorPlot = factorPlotVec instance AmbyContainer (U.Vector Double) where type Value (U.Vector Double) = Double + plot = plotVec plot' = plotVec' plotEq = plotEqVec @@ -70,53 +78,46 @@ kdePlot' = kdePlotVec' rugPlot = rugPlotVec rugPlot' = rugPlotVec' + boxPlot = boxPlotVec + boxPlot' = boxPlotVec' + factorPlot v = factorPlotVec (G.convert v) instance (Real a) => AmbyContainer [a] where type Value [a] = a - plot :: [a] -> [a] -> State PlotOpts () -> AmbyChart () plot x y optsState = plotList vals opts where opts = execState optsState def - vals = L.zipWith (\a b -> (realToFrac a, realToFrac b)) x y - - plot' :: [a] -> [a] -> AmbyChart () + vals = L.zipWith realToTuple x y plot' x y = plot x y $ return () - plotEq :: [a] -> (a -> a) -> State PlotEqOpts () -> AmbyChart () plotEq x fn optsState = plotList vals $ def & color .~ (opts ^. color) where opts = execState optsState def - vals = L.zipWith (\a b -> (realToFrac a, realToFrac b)) x $ map fn x - - plotEq' :: [a] -> (a -> a) -> AmbyChart () + vals = L.zipWith realToTuple x $ map fn x plotEq' x fn = plotEq x fn $ return () - distPlot :: [a] -> State DistPlotOpts () -> AmbyChart () - distPlot xs optsState = distPlotVec valsVec optsState - where - valsVec = (V.map realToFrac . V.fromList) xs - - distPlot' :: [a] -> AmbyChart () + distPlot xs optsState = distPlotVec (realToVec xs) optsState distPlot' xs = distPlot xs $ return () - kdePlot :: [a] -> State KdePlotOpts () -> AmbyChart () - kdePlot xs optsState = kdePlotVec valsVec optsState - where - valsVec = (V.map realToFrac . V.fromList) xs - - kdePlot' :: [a] -> AmbyChart () + kdePlot xs optsState = kdePlotVec (realToVec xs) optsState kdePlot' xs = kdePlot xs $ return () - rugPlot :: [a] -> State RugPlotOpts () -> AmbyChart () - rugPlot xs optsState = rugPlotVec valsVec optsState - where - valsVec = (V.map realToFrac . V.fromList) xs - - rugPlot' :: [a] -> AmbyChart () + rugPlot xs optsState = rugPlotVec (realToVec xs) optsState rugPlot' xs = rugPlot xs $ return () + boxPlot xs optsState = boxPlotVec (realToVec xs) optsState + boxPlot' xs = boxPlot xs $ return () + + factorPlot xs optsState = factorPlotVec (realToVec xs) optsState + +realToVec :: (Real a) => [a] -> V.Vector Double +realToVec = V.map realToFrac . V.fromList + +realToTuple :: Real a => a -> a -> (Double, Double) +realToTuple a b = (realToFrac a, realToFrac b) + -------------------------- -- Generic vec plotters -------------------------- @@ -145,11 +146,13 @@ => v Double -> (Double -> Double) -> AmbyChart () plotEqVec' x fn = plotEqVec x fn $ return () -distPlotVec :: (G.Vector v Double) => v Double -> State DistPlotOpts () +distPlotVec :: (G.Vector v Double, G.Vector v (Double, Double)) + => v Double -> State DistPlotOpts () -> AmbyChart () distPlotVec xs optsState = plotDistribution xs $ execState optsState def -distPlotVec' :: (G.Vector v Double) => v Double -> AmbyChart () +distPlotVec' :: (G.Vector v Double, G.Vector v (Double, Double)) + => v Double -> AmbyChart () distPlotVec' xs = distPlotVec xs $ return () kdePlotVec :: (G.Vector v Double) => v Double -> State KdePlotOpts () @@ -166,7 +169,7 @@ kdePlotVec' :: (G.Vector v Double) => v Double -> AmbyChart () kdePlotVec' xs = kdePlotVec xs $ return () -rugPlotVec :: (G.Vector v Double) +rugPlotVec :: (G.Vector v Double, G.Vector v (Double, Double)) => v Double -> State RugPlotOpts () -> AmbyChart () rugPlotVec xs optsState = do @@ -178,7 +181,7 @@ where opts = execState optsState def -rugPlotVec' :: (G.Vector v Double) +rugPlotVec' :: (G.Vector v Double, G.Vector v (Double, Double)) => v Double -> AmbyChart () rugPlotVec' xs = rugPlotVec xs $ return () @@ -186,7 +189,8 @@ -- Generic plotters -------------------------- -plotDistribution :: (G.Vector v Double) => v Double -> DistPlotOpts -> AmbyChart () +plotDistribution :: (G.Vector v Double, G.Vector v (Double, Double)) + => v Double -> DistPlotOpts -> AmbyChart () plotDistribution xs opts = do layout <- takeLayout putLayout $ do @@ -233,13 +237,19 @@ plot_hist_fill_style . Chart.fill_color .= Colour.dissolve 0.4 c plot_hist_vertical .= (opts ^. axis == YAxis) -plotRug :: (G.Vector v Double) +plotRug :: forall v. (G.Vector v Double, G.Vector v (Double, Double)) => AlphaColour Double -> v Double -> RugPlotOpts -> EC (Layout Double Double) () plotRug c xs opts = do maxMay <- getPlotMaxHeightMay h <- calcRugHeight maxMay - G.foldM (plotSingleLine h) () xs + Chart.plot $ return $ Chart.Plot + { Chart._plot_render = renderPlotRug h + , Chart._plot_legend = [("", const $ return ())] + , Chart._plot_all_points = join (***) G.toList + $ G.unzip + $ G.concatMap (toPoints h) xs + } updatePlotHeight maxMay where getPlotMaxHeightMay :: EC (Layout Double Double) (Maybe Double) @@ -250,15 +260,34 @@ & maximumMay & return + toPoints :: Double -> Double -> v (Double, Double) + toPoints h x = if opts ^. axis == XAxis + then G.fromList [(x, 0), (x, h)] + else G.fromList [(0, x), (h, x)] + calcRugHeight :: (Maybe Double) -> EC (Layout Double Double) Double calcRugHeight maxMay = return $ (Maybe.fromMaybe 1.0 maxMay) * (opts ^. height) - plotSingleLine :: Double -> () -> Double -> EC (Layout Double Double) () - plotSingleLine h _ x = if opts ^. axis == XAxis - then plotLine c (opts ^. linewidth) [(x, 0), (x, h)] - else plotLine c (opts ^. linewidth) [(0, x), (h, x)] + renderPlotRug :: Double -> Chart.PointMapFn Double Double + -> BackendProgram () + renderPlotRug h pmap = + Chart.withLineStyle lineStyle $ do + Chart.alignStrokePath (plotPath h pmap) >>= Chart.strokePath + where + lineStyle = def + & Chart.line_width .~ (opts ^. linewidth) + & Chart.line_color .~ c + plotPath :: Double -> Chart.PointMapFn Double Double -> Chart.Path + plotPath h pmap = + go (G.toList xs) + where + go [] = Chart.End + go [b] = Chart.MoveTo (pt b 0) $ Chart.LineTo (pt b h) $ Chart.End + go (b:rest) = Chart.MoveTo (pt b 0) $ Chart.LineTo (pt b h) $ go rest + pt x y = pmap (Chart.LValue x, Chart.LValue y) + updatePlotHeight :: (Maybe Double) -> EC (Layout Double Double) () updatePlotHeight maxMay = do @@ -316,35 +345,38 @@ -- Rendering -------------------------- +-- | Default save filename for Cairo. cairoDefSave :: FilePath cairoDefSave = ".__amby.png" +-- | Default save filename for Diagrams. diagramsDefSave :: FilePath diagramsDefSave = ".__amby.svg" +-- | Convert 'AmbyChart' into Chart's 'EC (Layout Double Double) ()'. getEC :: AmbyChart () -> EC (Layout Double Double) () getEC compute = getLayout $ execState compute def -getState :: AmbyChart () -> AmbyState -getState compute = execState compute def +-- | Convert 'AmbyGrid' into Chart's 'Renderable a'. +getRenderable :: AmbyChart () -> Renderable (LayoutPick Double Double Double) +getRenderable ch = getSaveObjectRenderable (toSaveObject ch) --- | Quick render. -- Short-hand to render to png file using Cairo backend. -save :: AmbyChart () -> IO () -save chart = Cairo.toFile +save :: Saveable s => s -> IO () +save chart = void $ Cairo.renderableToFile def { Cairo._fo_size = newSize } cairoDefSave - (getLayout st) + (getSaveObjectRenderable so) where - st = getState chart - newSize = getSize st + so = toSaveObject chart + newSize = getSize so -- | Short-hand to render to svg using Cairo backend -saveSvg :: AmbyChart () -> IO () -saveSvg chart = Diagrams.toFile +saveSvg :: Saveable s => s -> IO () +saveSvg chart = void $ Diagrams.renderableToFile def { Diagrams._fo_size = join (***) fromIntegral newSize } diagramsDefSave - (getLayout st) + (getSaveObjectRenderable so) where - st = getState chart - newSize = getSize st + so = toSaveObject chart + newSize = getSize so diff --git a/src/Amby/Style.hs b/src/Amby/Style.hs --- a/src/Amby/Style.hs +++ b/src/Amby/Style.hs @@ -6,7 +6,9 @@ {-# LANGUAGE CPP #-} module Amby.Style ( setThemeStyles + , setDefaultThemeStyles , scaledAxisCustom + , categoricalAxisData ) where @@ -42,9 +44,15 @@ Chart.layout_axes_styles . Chart.axis_grid_style . Chart.line_width .= 1.5 Chart.layout_axes_styles . Chart.axis_grid_style . Chart.line_dashes .= [] Chart.layout_axes_styles . Chart.axis_label_gap .= 8 + Chart.layout_margin .= 10 + -- TODO: Chart does not give a way to specify space between axis + -- tick labels and axis label + +setDefaultThemeStyles :: Theme -> EC (Layout x y) () +setDefaultThemeStyles theme = do + setThemeStyles theme Chart.layout_x_axis . Chart.laxis_override .= roundAxisData Chart.layout_y_axis . Chart.laxis_override .= roundAxisData - Chart.layout_margin .= 10 --- | Equalizes precision for all labels. --- For example the labels [0, 0.2] become [0.0, 0.2]. @@ -60,11 +68,19 @@ where precision = maximum $ map (countAfterDecimal . snd) xs +categoricalAxisData :: [(x, String)] -> Chart.AxisData x -> Chart.AxisData x +categoricalAxisData labels axisData = axisData + & Chart.axis_grid .~ [] + & Chart.axis_labels .~ [labels] + & Chart.axis_ticks .~ [] + ------------------------ -- Scaling ------------------------ --- | Take from the 'Chart' package with minor modifications. +-- | Taken from the 'Chart' package with minor modifications. +-- Needed to enforce 'xlim' and 'ylim' maximum and minimum limits. +-- Default version snaps to next available grid position. scaledAxisCustom :: RealFloat a => Chart.LinearAxisParams a -> (a, a) -> Chart.AxisFn a scaledAxisCustom lap rs@(minV,maxV) ps0 = makeAxisCustom' diff --git a/src/Amby/Theme.hs b/src/Amby/Theme.hs --- a/src/Amby/Theme.hs +++ b/src/Amby/Theme.hs @@ -5,11 +5,15 @@ module Amby.Theme ( Theme(..) , AmbyColor(..) + , Palette -- * Themes , mutedTheme , deepTheme , cleanTheme + , plainTheme + , easterTheme + , springTheme -- * Lenses , bgColor @@ -23,14 +27,32 @@ , hexToRgb , hexToRgba , toColour + , huslPalette + , lightPalette + , desaturate + , alphaToHsl + , hslToAlpha ) where import Control.Lens -import Data.Colour -import Data.Colour.SRGB import Data.Default +import Data.Fixed (mod') +import qualified Data.Maybe as Maybe +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import Data.Colour (AlphaColour, opaque) +import qualified Data.Colour as Colour +import Data.Colour.SRGB (sRGB, toSRGB, sRGB24read) +import Data.Colour.RGBSpace (uncurryRGB) +import Data.Colour.RGBSpace.HSL (hsl, hslView) + +import Amby.Numeric + +type Palette = [AlphaColour Double] + -- | Used to style a chart. data Theme = Theme { _themeBgColor :: AlphaColour Double @@ -38,12 +60,12 @@ , _themeGridLineColor :: AlphaColour Double , _themeFontFamily :: String , _themeFontSize :: Double - , _themeColorCycle :: [AlphaColour Double] - } + , _themeColorCycle :: Palette + } deriving (Show) makeFields ''Theme instance Default Theme where - def = deepTheme + def = plainTheme -- | Api facing color selection. data AmbyColor = @@ -52,6 +74,23 @@ | CustomColor (AlphaColour Double) deriving (Show, Eq) +plainTheme :: Theme +plainTheme = Theme + { _themeBgColor = opaque (sRGB24read "#FFFFFF") + , _themePlotBgColor = opaque (sRGB24read "#EAEAF2") + , _themeGridLineColor = opaque (sRGB24read "#FFFFFF") + , _themeFontFamily = "Verdana" + , _themeFontSize = 14 + , _themeColorCycle = + [ opaque (sRGB24read "#4A70B2") + , opaque (sRGB24read "#52A966") + , opaque (sRGB24read "#C64D4F") + , opaque (sRGB24read "#8170B4") + , opaque (sRGB24read "#CDBA70") + , opaque (sRGB24read "#60B5CF") + ] + } + mutedTheme :: Theme mutedTheme = Theme { _themeBgColor = opaque (sRGB24read "#FFFFFF") @@ -86,11 +125,51 @@ ] } +easterTheme :: Theme +easterTheme = Theme + { _themeBgColor = opaque (sRGB24read "#FFFFFF") + , _themePlotBgColor = opaque (sRGB24read "#EAEAF2") + , _themeGridLineColor = opaque (sRGB24read "#FFFFFF") + , _themeFontFamily = "Verdana" + , _themeFontSize = 14 + , _themeColorCycle = + [ opaque (sRGB24read "#8BD3C7") + , opaque (sRGB24read "#FEFFAF") + , opaque (sRGB24read "#BFBADA") + , opaque (sRGB24read "#FB8071") + , opaque (sRGB24read "#7FB0D3") + , opaque (sRGB24read "#FEB55A") + , opaque (sRGB24read "#B2DF60") + , opaque (sRGB24read "#FCCCE3") + , opaque (sRGB24read "#D8D6D8") + , opaque (sRGB24read "#BD7FBE") + ] + } + +springTheme :: Theme +springTheme = Theme + { _themeBgColor = opaque (sRGB24read "#FFFFFF") + , _themePlotBgColor = opaque (sRGB24read "#EAEAF2") + , _themeGridLineColor = opaque (sRGB24read "#FFFFFF") + , _themeFontFamily = "Verdana" + , _themeFontSize = 14 + , _themeColorCycle = + [ opaque (sRGB24read "#62C3A5") + , opaque (sRGB24read "#FC8D5C") + , opaque (sRGB24read "#8C9ECC") + , opaque (sRGB24read "#E888C4") + , opaque (sRGB24read "#A5DA48") + , opaque (sRGB24read "#FFDA00") + ] + } + cleanTheme :: Theme -cleanTheme = def +cleanTheme = Theme { _themeBgColor = opaque (sRGB24read "#FFFFFF") , _themePlotBgColor = opaque (sRGB24read "#FFFFFF") , _themeGridLineColor = opaque (sRGB24read "#EEEEEE") + , _themeFontFamily = "Verdana" + , _themeFontSize = 14 , _themeColorCycle = [ opaque (sRGB24read "#1776B6") , opaque (sRGB24read "#FF962A") @@ -108,7 +187,7 @@ hexToRgb s = CustomColor $ opaque (sRGB24read s) hexToRgba :: String -> Double -> AmbyColor -hexToRgba s a = CustomColor $ withOpacity (sRGB24read s) a +hexToRgba s a = CustomColor $ Colour.withOpacity (sRGB24read s) a -- | Conversion from Amby Api 'Color' to underlying 'Colour' type. toColour :: AmbyColor -> AlphaColour Double -> AlphaColour Double @@ -122,3 +201,78 @@ toColour C _ = opaque (sRGB24read "#77BEDB") toColour K _ = opaque (sRGB24read "#000000") toColour W _ = opaque (sRGB24read "#FFFFFF") + +-- | Get a set of evenly spaced colors in the HUSL space. +huslPalette :: Int -> Maybe Double -> Maybe Double -> Maybe Double -> Palette +huslPalette n hMay sMay lMay = V.toList huesBoxed + where + h = Maybe.fromMaybe 0.01 hMay + s = Maybe.fromMaybe 0.90 sMay + l = Maybe.fromMaybe 0.65 lMay + hues = U.init $ linspace 0 1 (n + 1) + hues' = (`U.map` hues) $ + (* 359) + . (`mod'` 1) + . (+ h) + huesBoxed = (`V.map` G.convert hues') $ + opaque + . uncurryRGB sRGB + . (\hi -> hsl hi s l) + +-- | Get sequential palette of colors from light to dark +lightPalette :: AlphaColour Double -> Int -> Palette +lightPalette c n = blendPalette lightColor c n + where + (h, s, _) = alphaToHsl c + lightColor = hslToAlpha h s 0.95 + +blendPalette :: AlphaColour Double -> AlphaColour Double -> Int -> Palette +blendPalette s e n + | n < 2 = modErr "blendPalette" "Need at least two colors to blend" + | n == 2 = [s, e] + | otherwise = + V.toList + $ (`V.snoc` e) + $ V.cons s + $ V.map (\x -> Colour.blend x s e) + $ G.convert + $ U.tail + $ U.init + $ linspace 0 1 n + +-- | Desaturate color by a proporation. +desaturate :: Double -> AlphaColour Double -> AlphaColour Double +desaturate p c + | p < 0 || p > 1 = + modErr "setSaturation" "Saturation proportion must be between [0, 1]" + | otherwise = hslToAlpha h (s * p) l + where + (h, s, l) = alphaToHsl c + +-- | Converts 'AlphaColour Double' to triplet of 'Double's in hsl encoding. +-- +-- Examples: +-- +-- >>> import qualified Data.Colour.Names as Colour +-- >>> alphaToHsl (opaque Colour.black) +-- (0.0,0.0,0.0) +-- +-- >>> alphaToHsl (opaque Colour.blue) +-- (240.0,1.0,0.5) +alphaToHsl :: AlphaColour Double -> (Double, Double, Double) +alphaToHsl c = hslView . toSRGB . (c `Colour.over`) $ Colour.black + +-- | Converts hsl triplet of 'Double's to 'AlphaColour Double'. +hslToAlpha :: Double -> Double -> Double -> AlphaColour Double +hslToAlpha h s l + | h < 0 || s < 0 || l < 0 = modErr + "hslToAlpha" "hsl accepts values in ([0, 365], [0,1], [0,1])" + | h > 365 || s > 1 || l > 1 = modErr + "hslToAlpha" "hsl accepts values in ([0, 365], [0,1], [0,1])" + | otherwise = opaque . uncurryRGB sRGB $ hsl h s l + +modErr :: String -> String -> a +modErr f err = error + $ showString "Amby.Theme." + $ showString f + $ showString ": " err diff --git a/src/Amby/Types.hs b/src/Amby/Types.hs --- a/src/Amby/Types.hs +++ b/src/Amby/Types.hs @@ -4,10 +4,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTSyntax #-} module Amby.Types ( AmbyContainer(..) , AmbyState , AmbyChart + , AmbyGrid + , ChartGrid + , Saveable(..) -- * General accessors , takeTheme @@ -15,23 +20,32 @@ , xlim , ylim , size + , title , takeLayout , getLayout , getSize , putLayout - , linewidth - , histLinewidth - , kdeLinewidth - , rugLinewidth + , getSaveObjectRenderable + -- * Grid + , gridTheme + , takeGridTheme + , gridSize + , gridScale + , setGrid + , chartToGrid + -- * Plot options , PlotOpts , PlotEqOpts , DistPlotOpts , KdePlotOpts , RugPlotOpts + , BoxPlotOpts(..) + , FactorPlotOpts(..) , Bandwidth(..) , Axis(..) + , PlotKind(..) , bins , hist , rug @@ -44,6 +58,28 @@ , gridsize , bw , color + , linewidth + , histLinewidth + , kdeLinewidth + , rugLinewidth + , kind + , hueLegend + , facLegend + + -- * Categorical options + , fac + , hue + , row + , col + , saturation + , facL + , hueL + , rowL + , colL + , datLabel + , facLabel + , rowLabel + , colLabel ) where @@ -51,13 +87,16 @@ import Control.Lens import Data.Default.Class -import Graphics.Rendering.Chart.Easy (EC, Layout) +import Graphics.Rendering.Chart.Easy (EC, Layout, LayoutPick, Renderable) import qualified Graphics.Rendering.Chart.Easy as Chart +import Graphics.Rendering.Chart.Grid (Grid) +import qualified Graphics.Rendering.Chart.Grid as Chart import Graphics.Rendering.Chart.Backend.Cairo (FileOptions(..)) import Amby.Compatibility.HistogramPlot import Amby.Theme import Amby.Style +import Amby.Categorical ----------------------------------- -- Parameter option types @@ -65,6 +104,7 @@ data Axis = XAxis | YAxis deriving (Show, Eq) data Bandwidth = Scott | BwScalar Double deriving (Show, Eq) +data PlotKind = Box deriving (Show, Eq) data PlotOpts = PlotOpts { _plotOptsColor :: AmbyColor @@ -118,9 +158,84 @@ , _rugPlotOptsAxis :: Axis , _rugPlotOptsColor :: AmbyColor , _rugPlotOptsLinewidth :: Double - } + } deriving (Show) makeFields ''RugPlotOpts +data BoxPlotOpts = BoxPlotOpts + { _boxPlotOptsFacL :: Category + , _boxPlotOptsHueL :: Category + , _boxPlotOptsColor :: AmbyColor + , _boxPlotOptsSaturation :: Double + , _boxPlotOptsAxis :: Axis + , _boxPlotOptsLinewidth :: Double + , _boxPlotOptsHueLegend :: Bool + , _boxPlotOptsFacLegend :: Bool + , _boxPlotOptsDatLabel :: String + , _boxPlotOptsFacLabel :: String + } deriving (Show) +makeFields ''BoxPlotOpts + +data FactorPlotOpts = FactorPlotOpts + { _factorPlotOptsFacL :: Category + , _factorPlotOptsHueL :: Category + , _factorPlotOptsColL :: Category + , _factorPlotOptsRowL :: Category + , _factorPlotOptsColor :: AmbyColor + , _factorPlotOptsSaturation :: Double + , _factorPlotOptsAxis :: Axis + , _factorPlotOptsKind :: PlotKind + , _factorPlotOptsDatLabel :: String + , _factorPlotOptsFacLabel :: String + , _factorPlotOptsRowLabel :: String + , _factorPlotOptsColLabel :: String + -- TODO: Polymorphic setters for labels? + } deriving (Show) +makeFields ''FactorPlotOpts + +class HasFac s a b | s -> a where + fac :: Setter s s a b +instance (Foldable f, Ord a, Show a) => HasFac BoxPlotOpts Category (f a) where + fac = sets (\a b -> b { _boxPlotOptsFacL = (toCat . a) (_boxPlotOptsFacL b) }) +instance HasFac BoxPlotOpts Category Category where + fac = sets (\a b -> b { _boxPlotOptsFacL = a (_boxPlotOptsFacL b) }) +instance (Foldable f, Ord a, Show a) => HasFac FactorPlotOpts Category (f a) where + fac = sets (\a b -> b + { _factorPlotOptsFacL = (toCat . a) (_factorPlotOptsFacL b) + }) +instance HasFac FactorPlotOpts Category Category where + fac = sets (\a b -> b { _factorPlotOptsFacL = a (_factorPlotOptsFacL b) }) + +class HasHue s a b | s -> a where + hue :: Setter s s a b +instance (Foldable f, Ord a, Show a) => HasHue BoxPlotOpts Category (f a) where + hue = sets (\a b -> b { _boxPlotOptsHueL = (toCat . a) (_boxPlotOptsHueL b) }) +instance HasHue BoxPlotOpts Category Category where + hue = sets (\a b -> b { _boxPlotOptsHueL = a (_boxPlotOptsHueL b) }) +instance (Foldable f, Ord a, Show a) => HasHue FactorPlotOpts Category (f a) where + hue = sets (\a b -> b + { _factorPlotOptsHueL = (toCat . a) (_factorPlotOptsHueL b) + }) +instance HasHue FactorPlotOpts Category Category where + hue = sets (\a b -> b { _factorPlotOptsHueL = a (_factorPlotOptsHueL b) }) + +class HasCol s a b | s -> a where + col :: Setter s s a b +instance (Foldable f, Ord a, Show a) => HasCol FactorPlotOpts Category (f a) where + col = sets (\a b -> b + { _factorPlotOptsColL = (toCat . a) (_factorPlotOptsColL b) + }) +instance HasCol FactorPlotOpts Category Category where + col = sets (\a b -> b { _factorPlotOptsColL = a (_factorPlotOptsColL b) }) + +class HasRow s a b | s -> a where + row :: Setter s s a b +instance (Foldable f, Ord a, Show a) => HasRow FactorPlotOpts Category (f a) where + row = sets (\a b -> b + { _factorPlotOptsRowL = (toCat . a) (_factorPlotOptsRowL b) + }) +instance HasRow FactorPlotOpts Category Category where + row = sets (\a b -> b { _factorPlotOptsRowL = a (_factorPlotOptsRowL b) }) + ----------------------------------- -- Main types ----------------------------------- @@ -132,10 +247,53 @@ } makeLenses ''AmbyState +data AmbyGridState = AmbyGridState + { _agsThemeState :: Theme + , _agsGrid :: Grid (Renderable (LayoutPick Double Double Double)) + , _agsSize :: (Int, Int) + } +makeLenses ''AmbyGridState + type AmbyChart a = State AmbyState a +type AmbyGrid a = State AmbyGridState a +type ChartGrid = Grid (Renderable (LayoutPick Double Double Double)) +data SaveObject = SaveObject + { _soSize :: (Int, Int) + , _soRenderable :: Renderable (LayoutPick Double Double Double) + } +makeLenses ''SaveObject + +class Saveable a where + toSaveObject :: a -> SaveObject + +instance Saveable (AmbyChart ()) where + toSaveObject ch = SaveObject + { _soSize = st ^. asSize + , _soRenderable = + ( Chart.layoutToRenderable + . Chart.execEC + . (^. asLayoutState) + ) st + } + where + st = execState ch def + +instance Saveable (AmbyGrid ()) where + toSaveObject ch = SaveObject + { _soSize = st ^. agsSize + , _soRenderable = + ( Chart.fillBackground def + . Chart.gridToRenderable + . (^. agsGrid) + ) st + } + where + st = execState ch def + class AmbyContainer c where type Value c :: * + plot :: c -> c -> State PlotOpts () -> AmbyChart () plot' :: c -> c -> AmbyChart () plotEq :: c -> (Value c -> Value c) -> State PlotEqOpts () -> AmbyChart () @@ -146,26 +304,35 @@ kdePlot' :: c -> AmbyChart () rugPlot :: c -> State RugPlotOpts () -> AmbyChart() rugPlot' :: c -> AmbyChart () + boxPlot :: c -> State BoxPlotOpts () -> AmbyChart () + boxPlot' :: c -> AmbyChart () + factorPlot :: c -> State FactorPlotOpts () -> AmbyGrid () ----------------------------------- -- General options ----------------------------------- +chartToGrid :: AmbyChart () -> Grid (Renderable (LayoutPick Double Double Double)) +chartToGrid ch = + Chart.layoutToGrid + $ Chart.execEC + $ getLayout + $ execState ch def + getLayout :: AmbyState -> EC (Layout Double Double) () getLayout s = s ^. asLayoutState -getSize :: AmbyState -> (Int, Int) -getSize s = s ^. asSize +getSize :: SaveObject -> (Int, Int) +getSize s = s ^. soSize +getSaveObjectRenderable :: SaveObject -> Renderable (LayoutPick Double Double Double) +getSaveObjectRenderable so = so ^. soRenderable + takeTheme :: AmbyChart Theme -takeTheme = do - t <- use asThemeState - return t +takeTheme = use asThemeState takeLayout :: AmbyChart (EC (Layout Double Double) ()) -takeLayout = do - l <- use asLayoutState - return l +takeLayout = use asLayoutState putLayout :: EC (Layout Double Double) () -> AmbyChart () putLayout l = do @@ -180,6 +347,14 @@ setThemeStyles t asThemeState .= t +gridTheme :: Theme -> AmbyGrid () +gridTheme t = do + agsThemeState .= t + +takeGridTheme :: AmbyGrid Theme +takeGridTheme = do + use agsThemeState + xlim :: (Double, Double) -> AmbyChart () xlim rs = do l <- use asLayoutState @@ -197,6 +372,27 @@ size :: (Int, Int) -> AmbyChart () size rs = asSize .= rs +title :: String -> AmbyChart () +title t = do + layout <- takeLayout + putLayout $ do + layout + Chart.layout_title .= t + Chart.layout_title_style . Chart.font_weight .= Chart.FontWeightNormal + +gridSize :: (Int, Int) -> AmbyGrid () +gridSize rs = agsSize .= rs + +-- | Scale current grid size by percentage. Scaling will snap to +-- nearest integer point. +gridScale :: (Double, Double) -> AmbyGrid () +gridScale (sx, sy) = do + (x, y) <- use agsSize + agsSize .= (round (fromIntegral x * sx), round (fromIntegral y * sy)) + +setGrid :: Grid (Renderable (LayoutPick Double Double Double)) -> AmbyGrid () +setGrid g = agsGrid .= g + -------------------- -- Default instances -------------------- @@ -206,10 +402,17 @@ { _asThemeState = def , _asLayoutState = do Chart.setColors $ (def :: Theme) ^. colorCycle - setThemeStyles def + setDefaultThemeStyles def , _asSize = _fo_size def } +instance Default AmbyGridState where + def = AmbyGridState + { _agsThemeState = def + , _agsGrid = Chart.empty + , _agsSize = _fo_size def + } + instance Default (PlotHist x Double) where def = PlotHist { _plot_hist_bins = 20 @@ -273,4 +476,34 @@ , _rugPlotOptsAxis = XAxis , _rugPlotOptsColor = DefaultColor , _rugPlotOptsLinewidth = 1.2 + } + +instance Default BoxPlotOpts where + def = BoxPlotOpts + { _boxPlotOptsFacL = DefaultCategory + , _boxPlotOptsHueL = DefaultCategory + , _boxPlotOptsColor = DefaultColor + , _boxPlotOptsSaturation = 0.8 + , _boxPlotOptsAxis = XAxis + , _boxPlotOptsLinewidth = 2 + , _boxPlotOptsFacLegend = True + , _boxPlotOptsHueLegend = True + , _boxPlotOptsDatLabel = "" + , _boxPlotOptsFacLabel = "" + } + +instance Default FactorPlotOpts where + def = FactorPlotOpts + { _factorPlotOptsFacL = DefaultCategory + , _factorPlotOptsHueL = DefaultCategory + , _factorPlotOptsColL = DefaultCategory + , _factorPlotOptsRowL = DefaultCategory + , _factorPlotOptsColor = DefaultColor + , _factorPlotOptsSaturation = 0.8 + , _factorPlotOptsAxis = XAxis + , _factorPlotOptsKind = Box + , _factorPlotOptsDatLabel = "" + , _factorPlotOptsFacLabel = "" + , _factorPlotOptsRowLabel = "" + , _factorPlotOptsColLabel = "" } diff --git a/src/Amby/Util.hs b/src/Amby/Util.hs new file mode 100644 --- /dev/null +++ b/src/Amby/Util.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +module Amby.Util + ( loadDataset + , getCol + + -- * Datasets + , Tip(..) + , Iris(..) + , tips + , getTipColumns + , iris + , getIrisColumns + + -- * Tip lenses + , totalBill + , tip + , sex + , day + , smoker + , time + , tipSize + + -- * Iris lenses + , sepalLength + , sepalWidth + , petalLength + , petalWidth + , irisClass + ) where + +import Control.Lens +import qualified Data.ByteString.Lazy as BL +import Data.Csv ((.:)) +import qualified Data.Csv as Csv +import qualified Data.Vector as V +import GHC.Generics +import Paths_amby (getDataFileName) + +import Numeric.Datasets (Dataset, getDataset) +import qualified Numeric.Datasets.Iris as Iris + +import Amby.Categorical + +loadDataset :: Dataset a -> IO [a] +loadDataset ds = do + getDataset ds + +data Tip = Tip + { _tipTotalBill :: !Double + , _tipTip :: !Double + , _tipSex :: !String + , _tipSmoker :: !String + , _tipDay :: !String + , _tipTime :: !String + , _tipTipSize :: !Int + } deriving (Generic) +makeFields ''Tip + +instance Show Tip where + show t = + showString "Tip " + $ showString "{totalBill = " + $ showString (show (_tipTotalBill t)) + $ showString ", tip = " + $ showString (show (_tipTip t)) + $ showString ", sex = " + $ showString (show (_tipSex t)) + $ showString ", smoker = " + $ showString (show (_tipSmoker t)) + $ showString ", day = " + $ showString (show (_tipDay t)) + $ showString ", time = " + $ showString (show (_tipTime t)) + $ showString ", tipSize = " + $ showString (show (_tipTipSize t)) "}" + +data TipColumns = TipColumns + { _tipColumnsTotalBill :: [Double] + , _tipColumnsTip :: [Double] + , _tipColumnsSex :: Category + , _tipColumnsSmoker :: Category + , _tipColumnsDay :: Category + , _tipColumnsTime :: Category + , _tipColumnsTipSize :: [Int] + } +makeFields ''TipColumns + +data Iris = Iris + { _irisSepalLength :: Double + , _irisSepalWidth :: Double + , _irisPetalLength :: Double + , _irisPetalWidth :: Double + , _irisIrisClass :: Iris.IrisClass + } deriving (Show) +makeFields ''Iris + +data IrisColumns = IrisColumns + { _irisColumnsSepalLength :: [Double] + , _irisColumnsSepalWidth :: [Double] + , _irisColumnsPetalLength :: [Double] + , _irisColumnsPetalWidth :: [Double] + , _irisColumnsIrisClass :: Category + } +makeFields ''IrisColumns + +class Loader a where + type RowValue a :: * + getCol :: Lens (RowValue a) (RowValue a) b b -> a -> b + +instance Loader [Tip] where + type RowValue [Tip] = TipColumns + getCol gtr ds = TipColumns + { _tipColumnsTotalBill = map (^. totalBill) ds + , _tipColumnsTip = map (^. tip) ds + , _tipColumnsSex = toCatOrdered (map (^. sex) ds) ["Male", "Female"] + , _tipColumnsSmoker = toCatOrdered (map (^. smoker) ds) ["Yes", "No"] + , _tipColumnsDay = toCatOrdered (map (^. day) ds) ["Thur", "Fri", "Sat", "Sun"] + , _tipColumnsTime = toCatOrdered (map (^. time) ds) ["Lunch", "Dinner"] + , _tipColumnsTipSize = map (^. tipSize) ds + } ^. gtr + +instance Loader [Iris] where + type RowValue [Iris] = IrisColumns + getCol gtr ds = IrisColumns + { _irisColumnsSepalLength = map (^. sepalLength) ds + , _irisColumnsSepalWidth = map (^. sepalWidth) ds + , _irisColumnsPetalLength = map (^. petalLength) ds + , _irisColumnsPetalWidth = map (^. petalWidth) ds + , _irisColumnsIrisClass = toCat (map (^. irisClass) ds) + } ^. gtr + +------------------------ +-- Tips dataset +------------------------ + +instance Csv.FromNamedRecord Tip where + parseNamedRecord m = Tip + <$> m .: "total_bill" + <*> m .: "tip" + <*> m .: "sex" + <*> m .: "smoker" + <*> m .: "day" + <*> m .: "time" + <*> m .: "size" +instance Csv.ToNamedRecord Tip +instance Csv.DefaultOrdered Tip + +tips :: Dataset Tip +tips _ = do + csvPath <- getDataFileName "data/seaborn_tips.csv" + dat <- BL.readFile csvPath + case Csv.decodeByName dat of + Left e -> error $ "Unable to parse csv file: " ++ e + Right (_hs, ds) -> return $ V.toList ds + +getTipColumns :: [Tip] + -> IO ( [Double] + , [Double] + , Category + , Category + , Category + , Category + , [Int] + ) +getTipColumns ts = return + ( getCol totalBill ts + , getCol tip ts + , getCol sex ts + , getCol smoker ts + , getCol day ts + , getCol time ts + , getCol tipSize ts + ) + +iris :: Dataset Iris +iris f = Iris.iris f >>= mapM dsIrisToIris + +dsIrisToIris :: Iris.Iris -> IO Iris +dsIrisToIris oIris = return $ Iris + { _irisSepalLength = Iris.sepalLength oIris + , _irisSepalWidth = Iris.sepalWidth oIris + , _irisPetalLength = Iris.petalLength oIris + , _irisPetalWidth = Iris.petalWidth oIris + , _irisIrisClass = Iris.irisClass oIris + } + +getIrisColumns :: [Iris] + -> IO ( [Double] + , [Double] + , [Double] + , [Double] + , Category + ) +getIrisColumns is = return + ( getCol sepalLength is + , getCol sepalWidth is + , getCol petalLength is + , getCol petalWidth is + , getCol irisClass is + ) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,6 +10,8 @@ main = do doctest [ "src/Amby/Numeric.hs" + , "src/Amby/Categorical.hs" + , "src/Amby/Theme.hs" ] defaultMain tests