diff --git a/Chart.cabal b/Chart.cabal --- a/Chart.cabal +++ b/Chart.cabal @@ -1,5 +1,5 @@ Name: Chart -Version: 0.7 +Version: 0.8 License: BSD3 License-file: LICENSE Copyright: Tim Docker, 2006 @@ -19,7 +19,7 @@ library if flag(splitbase) - Build-depends: base >= 3, old-locale, old-time, mtl + Build-depends: base >= 3, old-locale, time, mtl else Build-depends: base < 3 Build-depends: gtk >= 0.9.11, cairo >= 0.9.11, mtl @@ -31,6 +31,7 @@ Graphics.Rendering.Chart.Renderable, Graphics.Rendering.Chart.Axis, Graphics.Rendering.Chart.Layout, - Graphics.Rendering.Chart.Plot + Graphics.Rendering.Chart.Plot, + Graphics.Rendering.Chart.Pie, Graphics.Rendering.Chart.Simple diff --git a/Graphics/Rendering/Chart.hs b/Graphics/Rendering/Chart.hs --- a/Graphics/Rendering/Chart.hs +++ b/Graphics/Rendering/Chart.hs @@ -24,6 +24,7 @@ ToRenderable(..), Layout1(..), Axis(..), + LinearAxisParams(..), Plot(..), ToPlot(..), PlotPoints(..), @@ -32,10 +33,14 @@ PlotFillBetween(..), HAxis(..), VAxis(..), + LegendStyle(..), Rect(..), Point(..), Color(..), ErrPoint(..), + PieChart(..), + PieLayout(..), + PieItem(..), defaultAxisLineStyle, defaultPlotLineStyle, defaultAxis, @@ -44,6 +49,11 @@ defaultPlotLines, defaultPlotFillBetween, defaultLayout1, + defaultLinearAxis, + defaultPieLayout, + defaultPieChart, + defaultPieItem, + defaultLegendStyle, filledCircles, hollowCircles, exes, plusses, stars, @@ -52,7 +62,6 @@ solidLine, dashedLine, solidFillStyle, - fontStyle, independentAxes, linkedAxes, linkedAxes', @@ -63,13 +72,13 @@ autoScaledLogAxis', timeAxis, autoTimeAxis, - formatTime, days, months, years, renderableToPNGFile, renderableToPDFFile, renderableToPSFile, - doubleFromClockTime, - clockTimeFromDouble, + renderableToSVGFile, + doubleFromLocalTime, + localTimeFromDouble, CairoLineStyle(..), CairoFillStyle(..), CairoFontStyle(..) @@ -80,3 +89,4 @@ import Graphics.Rendering.Chart.Layout import Graphics.Rendering.Chart.Axis import Graphics.Rendering.Chart.Plot +import Graphics.Rendering.Chart.Pie diff --git a/Graphics/Rendering/Chart/Axis.hs b/Graphics/Rendering/Chart/Axis.hs --- a/Graphics/Rendering/Chart/Axis.hs +++ b/Graphics/Rendering/Chart/Axis.hs @@ -7,7 +7,7 @@ module Graphics.Rendering.Chart.Axis where import qualified Graphics.Rendering.Cairo as C -import System.Time +import Data.Time import System.Locale (defaultTimeLocale) import Control.Monad import Data.List @@ -113,9 +113,12 @@ renderAxis :: AxisT -> Rect -> CRender () renderAxis at@(AxisT et a) rect = do + let ls = axis_line_style a preserveCState $ do - setLineStyle (axis_line_style a) + setLineStyle ls{line_cap=C.LineCapSquare} strokeLines [Point sx sy,Point ex ey] + preserveCState $ do + setLineStyle ls{line_cap=C.LineCapButt} mapM_ drawTick (axis_ticks a) preserveCState $ do setFontStyle (axis_label_style a) @@ -195,12 +198,7 @@ explicitAxis :: Maybe Axis -> AxisFn explicitAxis ma _ = ma -linearTicks r = (major, minor) - where - major = steps 5 r - minor = steps 50 (fromRational (minimum major),fromRational (maximum major)) - -autoAxis labelf transform (rlabelvs, rtickvs) a = Just axis +autoAxis labelf transform (rlabelvs, rtickvs, rgridvs) a = Just axis where axis = a { axis_viewport=newViewport, @@ -218,27 +216,55 @@ gridvs = case (axis_grid a) of [] -> [] - _ -> labelvs + _ -> map fromRational rgridvs +data LinearAxisParams = LinearAxisParams { + -- | The function used to show the axes labels + la_labelf :: Double -> String, + + -- | The target number of labels to be shown + la_nLabels :: Int, + + -- | The target number of ticks to be shown + la_nTicks :: Int, + + -- | If True, the grid is shown at the label values, otherwise the + -- otherwise the grid is shown at the tick values + la_gridAtMinor :: Bool +} + +defaultLinearAxis = LinearAxisParams { + la_labelf = showD, + la_nLabels = 5, + la_nTicks = 50, + la_gridAtMinor = False +} + -- | Generate a linear axis automatically. -- The supplied axis is used as a template, with the viewport, ticks, labels -- and grid set appropriately for the data displayed against that axies. -- The resulting axis will only show a grid if the template has some grid -- values. -autoScaledAxis' :: (Double->String) -> Axis -> AxisFn -autoScaledAxis' labelf a ps0 = autoAxis labelf vmap (linearTicks (range ps)) a +autoScaledAxis' :: LinearAxisParams -> Axis -> AxisFn +autoScaledAxis' lap a ps0 = autoAxis (la_labelf lap) vmap (labelvs,tickvs,gridvs) a where ps = filter isValidNumber ps0 (min,max) = (minimum ps,maximum ps) range [] = (0,1) range _ | min == max = (min-0.5,min+0.5) | otherwise = (min,max) + labelvs = steps (fromIntegral (la_nLabels lap)) r + tickvs = steps (fromIntegral (la_nTicks lap)) (fromRational (minimum labelvs),fromRational (maximum labelvs)) + gridvs = case la_gridAtMinor lap of + False -> labelvs + True -> tickvs + r = range ps -- | Generate a linear axis automatically. -- Same as autoScaledAxis', but with labels generated with "showD" -- (showD is show for doubles, but with any trailing ".0" removed) autoScaledAxis :: Axis -> AxisFn -autoScaledAxis = autoScaledAxis' showD +autoScaledAxis = autoScaledAxis' defaultLinearAxis showD x = case reverse $ show x of '0':'.':r -> reverse r @@ -262,8 +288,8 @@ 5 gets a major ticks (ie the major ticks need to be a subset of the minor tick) -} -logTicks :: Range -> ([Rational],[Rational]) -logTicks (low,high) = (major,minor) +logTicks :: Range -> ([Rational],[Rational],[Rational]) +logTicks (low,high) = (major,minor,major) where ratio = high/low lower a l = let (i,r) = frac (log10 a) in @@ -358,45 +384,24 @@ ---------------------------------------------------------------------- -refClockTime = toClockTime CalendarTime { - ctYear=2000, - ctMonth=toEnum 0, - ctDay=1, - ctHour=0, - ctMin=0, - ctSec=0, - ctPicosec=0, - ctTZ=0, - ctWDay=Saturday, - ctYDay=0, - ctTZName="", - ctIsDST=False - } - --- | Map a clocktime value to a plot cordinate -doubleFromClockTime :: ClockTime -> Double -doubleFromClockTime ct = fromIntegral (tdSec (diffClockTimes ct refClockTime)) +-- | Map a LocalTime value to a plot cordinate +doubleFromLocalTime :: LocalTime -> Double +doubleFromLocalTime lt = fromIntegral (toModifiedJulianDay (localDay lt)) + + fromRational (timeOfDayToDayFraction (localTimeOfDay lt)) --- | Map a plot cordinate to a clocktime -clockTimeFromDouble :: Double -> ClockTime -clockTimeFromDouble v = (addToClockTime tdiff refClockTime) - where - tdiff = TimeDiff { - tdYear = 0, - tdMonth = 0, - tdDay = 0, - tdHour = 0, - tdMin = 0, - tdSec = floor v, - tdPicosec = 0 - } +-- | Map a plot cordinate to a LocalTime +localTimeFromDouble :: Double -> LocalTime +localTimeFromDouble v = + LocalTime (ModifiedJulianDay i) (dayFractionToTimeOfDay (toRational d)) + where + (i,d) = properFraction v -- | TimeSeq is a (potentially infinite) set of times. When passes -- a reference time, the function returns a a pair of lists. The first -- contains all times in the set less than the reference time in -- decreasing order. The second contains all times in the set greater -- than or equal to the reference time, in increasing order. -type TimeSeq = ClockTime-> ([ClockTime],[ClockTime]) +type TimeSeq = LocalTime-> ([LocalTime],[LocalTime]) coverTS tseq min max = min' ++ enumerateTS tseq min max ++ max' where @@ -412,16 +417,12 @@ _ -> False -- | How to display a time -type TimeLabelFn = ClockTime -> String - --- | Use an strftime() formatted string to display a time -formatTime :: String -> TimeLabelFn -formatTime s t = formatCalendarTime defaultTimeLocale s (toUTCTime t) +type TimeLabelFn = LocalTime -> String -- | Create an 'AxisFn' to for a time axis. The first 'TimeSeq' sets the minor ticks, -- and the ultimate range will aligned to it's elements. The second 'TimeSeq' sets --- the labels and grid. The 'TimeLabelFn' is used to format clocktimes for labels. --- The values to be plotted against this axis can be created with 'doubleFromClockTime' +-- the labels and grid. The 'TimeLabelFn' is used to format LocalTimes for labels. +-- The values to be plotted against this axis can be created with 'doubleFromLocalTime' timeAxis :: TimeSeq -> TimeSeq -> TimeLabelFn -> Axis -> AxisFn timeAxis tseq lseq labelf a pts = Just axis where @@ -432,11 +433,11 @@ axis_grid=[ t | t <- ltimes', visible t] } (min,max) = case pts of - [] -> (refClockTime,refClockTime) + [] -> (refLocalTime,refLocalTime) ps -> let min = minimum ps max = maximum ps in (ctfd min,ctfd max) - + refLocalTime = LocalTime (ModifiedJulianDay 0) midnight times = coverTS tseq min max ltimes = coverTS lseq min max ltimes' = map dfct ltimes @@ -444,50 +445,52 @@ max' = maximum times visible t = dfct min' <= t && t <= dfct max' labels = [ ((dfct m2 + dfct m1) / 2, labelf m1) | (m1,m2) <- zip ltimes (tail ltimes) ] - dfct = doubleFromClockTime - ctfd = clockTimeFromDouble + dfct = doubleFromLocalTime + ctfd = localTimeFromDouble -- | A 'TimeSeq' for calendar days days :: TimeSeq -days t = (iterate rev t1, tail (iterate fwd t1)) - where t0 = (toClockTime.zeroTime.toUTCTime) t - t1 = if t0 < t then t0 else (rev t0) - rev = addToClockTime noTimeDiff{tdDay=(-1)} - fwd = addToClockTime noTimeDiff{tdDay=1} +days t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) + where t0 = (localDay t) + t1 = if (toTime t0) < t then t0 else (rev t0) + rev = pred + fwd = succ + toTime d = LocalTime d midnight -- | A 'TimeSeq' for calendar months months :: TimeSeq -months t = (iterate rev t1, tail (iterate fwd t1)) - where t0 = (toClockTime.(\t -> t{ctDay=1}).zeroTime.toUTCTime) t - t1 = if t0 < t then t0 else (rev t0) - rev = addToClockTime noTimeDiff{tdMonth=(-1)} - fwd = addToClockTime noTimeDiff{tdMonth=1} +months t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) + where t0 = let (y,m,d) = toGregorian $ localDay t in fromGregorian y m 1 + t1 = if toTime t0 < t then t0 else (rev t0) + rev = addGregorianMonthsClip (-1) + fwd = addGregorianMonthsClip 1 + toTime d = LocalTime d midnight -- | A 'TimeSeq' for calendar years years :: TimeSeq -years t = (iterate rev t1, tail (iterate fwd t1)) - where t0 = (toClockTime.(\t -> t{ctMonth=January,ctDay=1}).zeroTime.toUTCTime) t - t1 = if t0 < t then t0 else (rev t0) - rev = addToClockTime noTimeDiff{tdMonth=(-12)} - fwd = addToClockTime noTimeDiff{tdMonth=12} - -zeroTime t = t{ctHour=0,ctMin=0,ctSec=0,ctPicosec=0} +years t = (map toTime $ iterate rev t1, map toTime $ tail (iterate fwd t1)) + where t0 = let (y,m,d) = toGregorian $ localDay t in y + t1 = if toTime t0 < t then t0 else (rev t0) + rev = pred + fwd = succ + toTime y = LocalTime (fromGregorian y 1 1) midnight -- | Automatically choose a suitable time axis, based upon the time range of data. --- The values to be plotted against this axis can be created with 'doubleFromClockTime' +-- The values to be plotted against this axis can be created with 'doubleFromLocalTime' autoTimeAxis :: Axis -> AxisFn autoTimeAxis a pts = - if tdiff < (normalizeTimeDiff noTimeDiff{tdDay=15}) - then timeAxis days days (formatTime "%d-%b") a pts - else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=3}) - then timeAxis days months (formatTime "%b-%y") a pts - else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=15}) - then timeAxis months months (formatTime "%b-%y") a pts - else if tdiff < (normalizeTimeDiff noTimeDiff{tdMonth=60}) - then timeAxis months years (formatTime "%Y") a pts - else timeAxis years years (formatTime "%Y") a pts + if tdiff < 15 + then timeAxis days days (ft "%d-%b") a pts + else if tdiff < 90 + then timeAxis days months (ft "%b-%y") a pts + else if tdiff < 450 + then timeAxis months months (ft "%b-%y") a pts + else if tdiff < 1800 + then timeAxis months years (ft "%Y") a pts + else timeAxis years years (ft "%Y") a pts where - tdiff = normalizeTimeDiff (t1 `diffClockTimes` t0) - t1 = clockTimeFromDouble (maximum pts) - t0 = clockTimeFromDouble (minimum pts) + tdiff = t1 - t0 + t1 = maximum pts + t0 = minimum pts + ft = formatTime defaultTimeLocale diff --git a/Graphics/Rendering/Chart/Gtk.hs b/Graphics/Rendering/Chart/Gtk.hs --- a/Graphics/Rendering/Chart/Gtk.hs +++ b/Graphics/Rendering/Chart/Gtk.hs @@ -39,6 +39,4 @@ G.renderWithDrawable win $ runCRender (rfn rect) bitmapEnv return True where - rfn rect = do - alignPixels - render chart rect + rfn rect = render chart rect diff --git a/Graphics/Rendering/Chart/Layout.hs b/Graphics/Rendering/Chart/Layout.hs --- a/Graphics/Rendering/Chart/Layout.hs +++ b/Graphics/Rendering/Chart/Layout.hs @@ -13,6 +13,7 @@ import Graphics.Rendering.Chart.Plot import Graphics.Rendering.Chart.Renderable import Control.Monad +import Control.Monad.Reader (local) -- | The side of an horizontal axis data HAxis = HA_Top | HA_Bottom deriving (Eq) @@ -30,7 +31,8 @@ layout1_vertical_axes :: AxesFn, layout1_margin :: Double, layout1_plots :: [(String,HAxis,VAxis,Plot)], - layout1_legend :: Maybe(LegendStyle) + layout1_legend :: Maybe(LegendStyle), + layout1_grid_last :: Bool } instance ToRenderable Layout1 where @@ -90,13 +92,11 @@ renderPlots l r@(Rect p1 p2) = preserveCState $ do -- render the plots setClipRegion p1 p2 - mapM_ (rPlot r) (layout1_plots l) - -- render the axes grids - maybeM () (renderAxisGrid r) tAxis - maybeM () (renderAxisGrid r) bAxis - maybeM () (renderAxisGrid r) lAxis - maybeM () (renderAxisGrid r) rAxis + when (not (layout1_grid_last l)) renderGrids + local (const vectorEnv) $ do + mapM_ (rPlot r) (layout1_plots l) + when (layout1_grid_last l) renderGrids where (bAxis,lAxis,tAxis,rAxis) = getAxes l @@ -117,6 +117,12 @@ in plot_render p pmfn rPlot1 _ _ _ _ = return () + renderGrids = do + maybeM () (renderAxisGrid r) tAxis + maybeM () (renderAxisGrid r) bAxis + maybeM () (renderAxisGrid r) lAxis + maybeM () (renderAxisGrid r) rAxis + axesSpacer f1 a1 f2 a2 = embedRenderable $ do oh1 <- maybeM (0,0) axisOverhang a1 oh2 <- maybeM (0,0) axisOverhang a2 @@ -148,11 +154,12 @@ defaultLayout1 = Layout1 { layout1_background = solidFillStyle white, layout1_title = "", - layout1_title_style = fontStyle "sans" 15 C.FontSlantNormal C.FontWeightBold, + layout1_title_style = defaultFontStyle{font_size=15, font_weight=C.FontWeightBold}, layout1_horizontal_axes = linkedAxes (autoScaledAxis defaultAxis), layout1_vertical_axes = linkedAxes (autoScaledAxis defaultAxis), layout1_margin = 10, layout1_plots = [], - layout1_legend = Just defaultLegendStyle + layout1_legend = Just defaultLegendStyle, + layout1_grid_last = False } diff --git a/Graphics/Rendering/Chart/Pie.hs b/Graphics/Rendering/Chart/Pie.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Chart/Pie.hs @@ -0,0 +1,154 @@ +module Graphics.Rendering.Chart.Pie where +-- original code thanks to Neal Alexander + +import qualified Graphics.Rendering.Cairo as C + +import Data.List +import Data.Bits +import Control.Monad + +import Graphics.Rendering.Chart.Types +import Graphics.Rendering.Chart.Renderable + +data PieLayout = PieLayout { + pie_title :: String, + pie_title_style :: CairoFontStyle, + pie_plot :: PieChart, + pie_background :: CairoFillStyle, + pie_margin :: Double +} + +data PieChart = PieChart { + pie_data :: [PieItem], + pie_colors :: [Color], + pie_label_style :: CairoFontStyle, + pie_label_line_style :: CairoLineStyle, + pie_start_angle :: Double + +} + +data PieItem = PieItem { + pitem_label :: String, + pitem_offset :: Double, + pitem_value :: Double +} + +defaultPieChart = PieChart { + pie_data = [], + pie_colors = defaultColorSeq, + pie_label_style = defaultFontStyle, + pie_label_line_style = solidLine 1 black, + pie_start_angle = 0 +} + +defaultPieItem = PieItem "" 0 0 + +defaultPieLayout = PieLayout { + pie_background = solidFillStyle white, + pie_title = "", + pie_title_style = defaultFontStyle{font_size=15, font_weight=C.FontWeightBold}, + pie_plot = defaultPieChart, + pie_margin = 10 +} + +instance ToRenderable PieLayout where + toRenderable p = fillBackground (pie_background p) ( + vertical [ + (0, addMargins (lm/2,0,0,0) title), + (1, addMargins (lm,lm,lm,lm) (toRenderable $ pie_plot p)) + ] ) + where + title = label (pie_title_style p) HTA_Centre VTA_Top (pie_title p) + lm = pie_margin p + +instance ToRenderable PieChart where + toRenderable p = Renderable { + minsize=minsizePie p, + render=renderPie p + } + +extraSpace p = do + textSizes <- mapM textSize (map pitem_label (pie_data p)) + let maxw = foldr (max.fst) 0 textSizes + let maxh = foldr (max.snd) 0 textSizes + let maxo = foldr (max.pitem_offset) 0 (pie_data p) + let extra = label_rgap + label_rlength + maxo + return (extra + maxw, extra + maxh ) + +minsizePie p = do + (extraw,extrah) <- extraSpace p + return (extraw * 2, extrah * 2) + +renderPie p (Rect p1 p2) = do + (extraw,extrah) <- extraSpace p + let (w,h) = (p_x p2 - p_x p1, p_y p2 - p_y p1) + let center = Point (p_x p1 + w/2) (p_y p1 + h/2) + let radius = (min (w - 2*extraw) (h - 2*extrah)) / 2 + + foldM_ (paint center radius) (pie_start_angle p) (zip (pie_colors p) content) + + where + content = let total = sum (map pitem_value (pie_data p)) + in [ pi{pitem_value=pitem_value pi/total} | pi <- pie_data p ] + + paint :: Point -> Double -> Double -> (Color,PieItem) -> CRender Double + paint center radius a1 (color,pitem) = do + let ax = 360.0 * (pitem_value pitem) + let a2 = a1 + (ax / 2) + let a3 = a1 + ax + let offset = pitem_offset pitem + + pieSlice (ray a2 offset) a1 a3 color + pieLabel (pitem_label pitem) a2 offset + + return a3 + + where + pieLabel :: String -> Double -> Double -> CRender () + pieLabel name angle offset = do + setFontStyle (pie_label_style p) + setLineStyle (pie_label_line_style p) + + moveTo (ray angle (radius + label_rgap+offset)) + let p1 = (ray angle (radius + label_rgap + label_rlength+offset)) + lineTo p1 + (tw,th) <- textSize name + let (offset,anchor) = if angle < 90 || angle > 270 + then ((0+),HTA_Left) + else ((0-),HTA_Right) + c $ C.relLineTo (offset (tw + label_rgap)) 0 + c $ C.stroke + + let p2 = p1 `pvadd` (Vector (offset label_rgap) 0) + drawText anchor VTA_Bottom p2 name + + pieSlice :: Point -> Double -> Double -> Color -> CRender () + pieSlice (Point x y) a1 a2 color = c $ do + C.newPath + C.arc x y radius (radian a1) (radian a2) + C.lineTo x y + C.lineTo x y + C.closePath + + setSourceColor color + C.fillPreserve + C.setSourceRGBA 1 1 1 0.1 + + C.stroke + + ray :: Double -> Double -> Point + ray angle r = Point x' y' + where + x' = x + (cos' * x'') + y' = y + (sin' * x'') + cos' = (cos . radian) angle + sin' = (sin . radian) angle + x'' = ((x + r) - x) + x = p_x center + y = p_y center + + radian = (*(pi / 180.0)) + + +label_rgap = 5 +label_rlength = 15 diff --git a/Graphics/Rendering/Chart/Plot.hs b/Graphics/Rendering/Chart/Plot.hs --- a/Graphics/Rendering/Chart/Plot.hs +++ b/Graphics/Rendering/Chart/Plot.hs @@ -79,7 +79,10 @@ lineTo (Point (p_x p2) y) c $ C.stroke -defaultPlotLineStyle = solidLine 1 blue +defaultPlotLineStyle = (solidLine 1 blue){ + line_cap = C.LineCapRound, + line_join = C.LineJoinRound + } defaultPlotLines = PlotLines { plot_lines_style = defaultPlotLineStyle, diff --git a/Graphics/Rendering/Chart/Renderable.hs b/Graphics/Rendering/Chart/Renderable.hs --- a/Graphics/Rendering/Chart/Renderable.hs +++ b/Graphics/Rendering/Chart/Renderable.hs @@ -110,51 +110,43 @@ C.surfaceWriteToPNG result path where rfn = do - alignPixels render chart rect rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) --- | Output the given renderable to a PDF file of the specifed size --- (in points), to the specified file. -renderableToPDFFile :: Renderable -> Int -> Int -> FilePath -> IO () -renderableToPDFFile chart width height path = - C.withPDFSurface path (fromIntegral width) (fromIntegral height) $ \result -> do +renderableToFile withSurface chart width height path = + withSurface path (fromIntegral width) (fromIntegral height) $ \result -> do C.renderWith result $ runCRender rfn vectorEnv C.surfaceFinish result where rfn = do - render chart rect + render chart rect c $ C.showPage rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) +-- | Output the given renderable to a PDF file of the specifed size +-- (in points), to the specified file. +renderableToPDFFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToPDFFile = renderableToFile C.withPDFSurface + -- | Output the given renderable to a postscript file of the specifed size -- (in points), to the specified file. renderableToPSFile :: Renderable -> Int -> Int -> FilePath -> IO () -renderableToPSFile chart width height path = - C.withPSSurface path (fromIntegral width) (fromIntegral height) $ \result -> do - C.renderWith result $ runCRender rfn vectorEnv - C.surfaceFinish result - where - rfn = do - render chart rect - c $ C.showPage +renderableToPSFile = renderableToFile C.withPSSurface - rect = Rect (Point 0 0) (Point (fromIntegral width) (fromIntegral height)) +-- | Output the given renderable to an SVG file of the specifed size +-- (in points), to the specified file. +renderableToSVGFile :: Renderable -> Int -> Int -> FilePath -> IO () +renderableToSVGFile = renderableToFile C.withSVGSurface bitmapEnv = CEnv adjfn where - adjfn (Point x y)= Point (fromIntegral (round x)) (fromIntegral (round y)) + adjfn (Point x y)= Point (adj x) (adj y) + adj x = (fromIntegral (round (x-0.5)))+0.5 vectorEnv = CEnv id -alignPixels :: CRender () -alignPixels = do - -- move to centre of pixels so that stroke width of 1 is - -- exactly one pixel - c $ C.translate 0.5 0.5 - embedRenderable :: CRender Renderable -> Renderable embedRenderable ca = Renderable { minsize = do { a <- ca; minsize a }, @@ -182,6 +174,7 @@ minsizeLegend :: Legend -> CRender RectSize minsizeLegend (Legend _ ls plots) = do let labels = nub $ map fst plots + setFontStyle $ legend_label_style ls lsizes <- mapM textSize labels lgap <- legendSpacer let lm = legend_margin ls @@ -200,6 +193,7 @@ rf :: Point -> (String,[Plot]) -> CRender Point rf p1 (label,theseplots) = do + setFontStyle $ legend_label_style ls (w,h) <- textSize label lgap <- legendSpacer let p2 = (p1 `pvadd` Vector lps 0) @@ -265,7 +259,7 @@ vs = [VTA_Top, VTA_Centre, VTA_Bottom] fwhite = solidFillStyle white fblue = solidFillStyle (Color 0.8 0.8 1) - fs = fontStyle "sans" 30 C.FontSlantNormal C.FontWeightBold + fs = defaultFontStyle{font_size=30,font_weight=C.FontWeightBold} crossHairs r =Renderable { minsize = minsize r, render = \rect@(Rect (Point x1 y1) (Point x2 y2)) -> do diff --git a/Graphics/Rendering/Chart/Simple.hs b/Graphics/Rendering/Chart/Simple.hs --- a/Graphics/Rendering/Chart/Simple.hs +++ b/Graphics/Rendering/Chart/Simple.hs @@ -22,13 +22,13 @@ -- -- Examples: -- --- renderableToWindow (toRenderable $ plot [0,0.1..10] sin "sin(x)") 640 480 +-- @renderableToWindow (toRenderable $ plot [0,0.1..10] sin "sin(x)") 640 480@ -- --- plotWindow [0,1,3,4,8]] [12,15,1,5,8] "o" "points" +-- @plotWindow [0,1,3,4,8]] [12,15,1,5,8] "o" "points"@ -- --- plotPDF "foo.pdf" [0,0.1..10] sin "- " cos ". " cos "o" +-- @plotPDF "foo.pdf" [0,0.1..10] sin "- " cos ". " cos "o"@ -- --- plotPS "foo.ps" [0,0.1..10] (sin.exp) "- " (sin.exp) "o-" +-- @plotPS "foo.ps" [0,0.1..10] (sin.exp) "- " (sin.exp) "o-"@ ----------------------------------------------------------------------------- module Graphics.Rendering.Chart.Simple( plot, PlotKind(..), xcoords, plotWindow, plotPDF, plotPS @@ -221,6 +221,20 @@ instance PlotPSType (IO a) where pls fn args = do renderableToPSFile (toRenderable $ uplot (reverse args)) 640 480 fn return undefined + +-- | Save a plot as a png file +plotPNG :: PlotPNGType a => String -> a +plotPNG fn = plp fn [] + +class PlotPNGType t where + plp :: FilePath -> [UPlot] -> t +instance (PlotArg a, PlotPNGType r) => PlotPNGType (a -> r) where + plp fn args = \ a -> plp fn (toUPlot a ++ args) +instance PlotPNGType (IO a) where + plp fn args = do renderableToPNGFile (toRenderable $ uplot (reverse args)) 640 480 fn + return undefined + + data UPlot = UString String | UDoubles [Double] | UFunction (Double -> Double) | UKind [PlotKind] | X [Double] diff --git a/Graphics/Rendering/Chart/Types.hs b/Graphics/Rendering/Chart/Types.hs --- a/Graphics/Rendering/Chart/Types.hs +++ b/Graphics/Rendering/Chart/Types.hs @@ -91,23 +91,29 @@ -- style, at the supplied device coordinates. newtype CairoPointStyle = CairoPointStyle (Point -> CRender ()) --- | Abstract data type for the style of a line --- --- The contained Cairo action sets the required line --- in the Cairo rendering state. -newtype CairoLineStyle = CairoLineStyle (CRender ()) - +-- | Data type for the style of a line +data CairoLineStyle = CairoLineStyle { + line_width :: Double, + line_color :: Color, + line_dashes :: [Double], + line_cap :: C.LineCap, + line_join :: C.LineJoin +} + -- | Abstract data type for a fill style -- -- The contained Cairo action sets the required fill -- style in the Cairo rendering state. newtype CairoFillStyle = CairoFillStyle (CRender ()) --- | Abstract data type for a font. --- --- The contained Cairo action sets the required font --- in the Cairo rendering state. -newtype CairoFontStyle = CairoFontStyle (CRender ()) +-- | Data type for a font +data CairoFontStyle = CairoFontStyle { + font_name :: String, + font_size :: Double, + font_slant :: C.FontSlant, + font_weight :: C.FontWeight, + font_color :: Color +} type Range = (Double,Double) type RectSize = (Double,Double) @@ -119,6 +125,7 @@ green = Color 0 1 0 blue = Color 0 0 1 +defaultColorSeq = cycle [blue,red,green, Color 1 1 0,Color 0 1 1,Color 1 0 1 ] ---------------------------------------------------------------------- -- Assorted helper functions in Cairo Usage @@ -163,8 +170,20 @@ C.lineTo x1 y2 C.lineTo x1 y1 -setFontStyle (CairoFontStyle s) = s -setLineStyle (CairoLineStyle s) = s +setFontStyle f = do + c $ C.selectFontFace (font_name f) (font_slant f) (font_weight f) + c $ C.setFontSize (font_size f) + c $ setSourceColor (font_color f) + +setLineStyle ls = do + c $ C.setLineWidth (line_width ls) + c $ setSourceColor (line_color ls) + c $ C.setLineCap (line_cap ls) + c $ C.setLineJoin (line_join ls) + case line_dashes ls of + [] -> return () + ds -> c $ C.setDash ds 0 + setFillStyle (CairoFillStyle s) = s setSourceColor (Color r g b) = C.setSourceRGB r g b @@ -336,33 +355,14 @@ Double -- ^ width of line -> Color -> CairoLineStyle -solidLine w cl = CairoLineStyle (do - c $ C.setLineWidth w - c $ setSourceColor cl - ) +solidLine w cl = CairoLineStyle w cl [] C.LineCapButt C.LineJoinMiter dashedLine :: Double -- ^ width of line -> [Double] -- ^ the dash pattern in device coordinates -> Color -> CairoLineStyle -dashedLine w dashes cl = CairoLineStyle (do - c $ C.setDash dashes 0 - c $ C.setLineWidth w - c $ setSourceColor cl - ) - -fontStyle :: - String -- ^ the font name - -> Double -- ^ the font size - -> C.FontSlant -- ^ the font slant - -> C.FontWeight -- ^ the font weight - -> CairoFontStyle -fontStyle name size slant weight = CairoFontStyle fn - where - fn = do - c $ C.selectFontFace name slant weight - c $ C.setFontSize size +dashedLine w ds cl = CairoLineStyle w cl ds C.LineCapButt C.LineJoinMiter solidFillStyle :: Color @@ -371,6 +371,13 @@ where fn = c $ setSourceColor cl defaultPointStyle = filledCircles 1 white -defaultFontStyle = CairoFontStyle (return ()) + +defaultFontStyle = CairoFontStyle { + font_name = "sans", + font_size = 10, + font_slant = C.FontSlantNormal, + font_weight = C.FontWeightNormal, + font_color = black +} isValidNumber v = not (isNaN v) && not (isInfinite v) diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -5,14 +5,17 @@ import System.Environment(getArgs) import System.Time import System.Random +import Data.Time.Calendar +import Data.Time.LocalTime import Prices -data OutputType = Window | PNG | PS | PDF +data OutputType = Window | PNG | PS | PDF | SVG chooseLineWidth Window = 1.0 chooseLineWidth PNG = 1.0 chooseLineWidth PDF = 0.25 chooseLineWidth PS = 0.25 +chooseLineWidth SVG = 0.25 blue = (Color 0 0 1) green = (Color 0 1 0) @@ -21,8 +24,8 @@ red1 = (Color 0.5 0.5 1) ---------------------------------------------------------------------- -test1 :: OutputType -> IO Layout1 -test1 otype = return layout +test1 :: OutputType -> IO Renderable +test1 otype = return (toRenderable layout) where am :: Double -> Double am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) @@ -47,54 +50,86 @@ lineWidth = chooseLineWidth otype + +test1a :: OutputType -> IO Renderable +test1a otype = return (toRenderable layout) + where + am :: Double -> Double + am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5)) + + sinusoid1 = defaultPlotLines { + plot_lines_values = [[ (Point x (am x)) | x <- [0,(0.5)..400]]], + plot_lines_style = solidLine lineWidth blue + } + + sinusoid2 = defaultPlotPoints { + plot_points_style=filledCircles 2 red, + plot_points_values = [ (Point x (am x)) | x <- [0,7..400]] + } + + lap = defaultLinearAxis{la_nLabels=2,la_nTicks=20,la_gridAtMinor=True} + + layout = defaultLayout1 { + layout1_title="Amplitude Modulation", + layout1_horizontal_axes=linkedAxes (autoScaledAxis' lap defaultAxis), + layout1_vertical_axes=linkedAxes (autoScaledAxis' lap defaultAxis), + layout1_plots = [("am",HA_Bottom,VA_Left,(toPlot sinusoid1)), + ("am points", HA_Bottom,VA_Left,(toPlot sinusoid2))] + } + + lineWidth = chooseLineWidth otype + ---------------------------------------------------------------------- -test2 :: OutputType -> [(Int,Int,Int,Double,Double)] -> IO Layout1 -test2 otype prices = return layout +test2 :: [(Int,Int,Int,Double,Double)] -> OutputType -> IO Renderable +test2 prices otype = return (toRenderable layout) where + lineStyle c = (plot_lines_style defaultPlotLines){ + line_width=3 * chooseLineWidth otype, + line_color = c + } + price1 = defaultPlotLines { - plot_lines_style = solidLine lineWidth blue, + plot_lines_style = lineStyle blue, plot_lines_values = [[ Point (date d m y) v | (d,m,y,v,_) <- prices]] } price2 = defaultPlotLines { - plot_lines_style = solidLine lineWidth green, + plot_lines_style = lineStyle green, plot_lines_values = [[ Point (date d m y) v | (d,m,y,_,v) <- prices]] } - gridlessAxis = defaultAxis{axis_grid=[]} - vaxis = autoScaledAxis gridlessAxis + baseAxis = defaultAxis{ + axis_grid=[], + axis_line_style=solidLine 1 fg, + axis_grid_style=solidLine 1 fg1, + axis_label_style=(axis_label_style defaultAxis){font_color=fg} + } + vaxis = autoScaledAxis baseAxis + bg = Color 0 0 0.25 + fg = Color 1 1 1 + fg1 = Color 0.0 0.0 0.15 + layout = defaultLayout1 { - layout1_title="Price History", - layout1_horizontal_axes=linkedAxes' (autoTimeAxis gridlessAxis), + layout1_title="Price History", + layout1_title_style=(layout1_title_style defaultLayout1){font_color=fg}, + layout1_background=solidFillStyle bg, + layout1_horizontal_axes=linkedAxes' (autoTimeAxis baseAxis), layout1_vertical_axes=independentAxes vaxis vaxis, layout1_plots = [("price 1", HA_Bottom,VA_Left,(toPlot price1)), - ("price 2", HA_Bottom,VA_Right,(toPlot price2))] + ("price 2", HA_Bottom,VA_Right,(toPlot price2))], + layout1_legend = Just (defaultLegendStyle{ + legend_label_style=(legend_label_style defaultLegendStyle){font_color=fg} + } ), + layout1_grid_last=False } - lineWidth = chooseLineWidth otype - -date dd mm yyyy = doubleFromClockTime ct - where - ct = toClockTime CalendarTime { - ctYear=yyyy, - ctMonth=toEnum (mm-1), - ctDay=dd, - ctHour=0, - ctMin=0, - ctSec=0, - ctPicosec=0, - ctTZ=0, - ctWDay=Monday, - ctYDay=0, - ctTZName="", - ctIsDST=False - } +date dd mm yyyy = doubleFromLocalTime (LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight) ---------------------------------------------------------------------- -test3 :: OutputType -> IO Layout1 -test3 otype = return layout +test3 :: OutputType -> IO Renderable +test3 otype = return (toRenderable layout) where price1 = defaultPlotFillBetween { @@ -116,8 +151,8 @@ } ---------------------------------------------------------------------- -test4 :: OutputType -> IO Layout1 -test4 otype = return layout +test4 :: OutputType -> IO Renderable +test4 otype = return (toRenderable layout) where points = defaultPlotPoints { @@ -141,10 +176,10 @@ ---------------------------------------------------------------------- -- Example thanks to Russell O'Connor -test5 :: OutputType -> IO Layout1 +test5 :: OutputType -> IO Renderable test5 otype = do bits <- fmap randoms getStdGen - return (layout 1001 (trial bits)) + return (toRenderable (layout 1001 (trial bits))) where layout n t = defaultLayout1 { layout1_title="Simulation of betting on a biased coin", @@ -178,8 +213,8 @@ ---------------------------------------------------------------------- -- Test the Simple interface -test6 :: OutputType -> IO Layout1 -test6 otype = return pp{layout1_title="Graphics.Rendering.Chart.Simple example"} +test6 :: OutputType -> IO Renderable +test6 otype = return (toRenderable pp{layout1_title="Graphics.Rendering.Chart.Simple example"}) where pp = plot xs sin "sin" cos "cos" "o" @@ -188,9 +223,10 @@ (const 0.5) [0.1,0.7,0.5::Double] "+" xs = [0,0.3..3] :: [Double] + ---------------------------------------------------------------------- -test7 :: OutputType -> IO Layout1 -test7 otype = return layout +test7 :: OutputType -> IO Renderable +test7 otype = return (toRenderable layout) where vals = [ (x,sin (exp x),sin x/2,cos x/10) | x <- [1..20]] bars = defaultPlotErrBars { @@ -207,18 +243,36 @@ ("test",HA_Bottom,VA_Left,(toPlot points))] } +---------------------------------------------------------------------- +test8 :: OutputType -> IO Renderable +test8 otype = return (toRenderable layout) + where + values = [ ("eggs",38,e), ("milk",45,e), ("bread",11,e1), ("salmon",8,e) ] + e = 0 + e1 = 25 + layout = defaultPieLayout { + pie_title = "Pie Chart Example", + pie_plot = defaultPieChart { + pie_data = [ defaultPieItem{pitem_value=v,pitem_label=s,pitem_offset=o} + | (s,v,o) <- values ] + } + } + ---------------------------------------------------------------------- +allTests :: [ (String, OutputType -> IO Renderable) ] allTests = - [ ("test1",test1) - , ("test2a",\ot -> test2 ot prices) - , ("test2b",\ot -> test2 ot (filterPrices (date 1 1 2005) (date 31 12 2005))) - , ("test2c",\ot -> test2 ot (filterPrices (date 1 5 2005) (date 1 7 2005))) - , ("test2d",\ot -> test2 ot (filterPrices (date 1 1 2006) (date 10 1 2006))) - , ("test3",test3) - , ("test4",test4) - , ("test5",test5) - , ("test6",test6) - , ("test7",test7) + [ ("test1", test1) + , ("test1a", test1a) + , ("test2a", test2 prices) + , ("test2b", test2 (filterPrices (date 1 1 2005) (date 31 12 2005))) + , ("test2c", test2 (filterPrices (date 1 5 2005) (date 1 7 2005))) + , ("test2d", test2 (filterPrices (date 1 1 2006) (date 10 1 2006))) + , ("test3", test3) + , ("test4", test4) + , ("test5", test5) + , ("test6", test6) + , ("test7", test7) + , ("test8", test8) ] filterPrices t1 t2 = [ v | v@(d,m,y,_,_) <- prices, let t = date d m y in t >= t1 && t <= t2] @@ -227,17 +281,22 @@ args <- getArgs main1 args +main1 :: [String] -> IO () main1 ("--png":tests) = showTests tests renderToPNG main1 ("--pdf":tests) = showTests tests renderToPDF +main1 ("--svg":tests) = showTests tests renderToSVG main1 ("--ps":tests) = showTests tests renderToPS main1 tests = showTests tests renderToWindow -showTests tests outputfn = mapM_ outputfn (filter (match tests) allTests) +showTests :: [String] -> ((String,OutputType -> IO Renderable) -> IO()) -> IO () +showTests tests ofn = mapM_ ofn (filter (match tests) allTests) +match :: [String] -> (String,a) -> Bool match [] t = True match ts t = (fst t) `elem` ts -renderToWindow (n,t) = t Window >>= \l -> renderableToWindow (toRenderable l) 640 480 -renderToPNG (n,t) = t PNG >>= \l -> renderableToPNGFile (toRenderable l) 640 480 (n ++ ".png") -renderToPS (n,t) = t PS >>= \l -> renderableToPSFile (toRenderable l) 640 480 (n ++ ".ps") -renderToPDF (n,t) = t PDF >>= \l -> renderableToPDFFile (toRenderable l) 640 480 (n ++ ".pdf") +renderToWindow (n,ir) = do { r <- ir Window; renderableToWindow r 640 480} +renderToPNG (n,ir) = do { r <- ir PNG; renderableToPNGFile r 640 480 (n ++ ".png")} +renderToPS (n,ir) = do { r <- ir PS; renderableToPSFile r 640 480 (n ++ ".ps")} +renderToPDF (n,ir) = do { r <- ir PDF; renderableToPDFFile r 640 480 (n ++ ".pdf")} +renderToSVG (n,ir) = do { r <- ir SVG; renderableToSVGFile r 640 480 (n ++ ".svg")}