diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -15,3 +15,6 @@ 0.1.1.4: * remove Unicode dependency + +0.1.2: + * improve axis line joins diff --git a/lib/Graphics/Rendering/Plot/Figure.hs b/lib/Graphics/Rendering/Plot/Figure.hs --- a/lib/Graphics/Rendering/Plot/Figure.hs +++ b/lib/Graphics/Rendering/Plot/Figure.hs @@ -59,6 +59,15 @@ , hist , candle, whisker , setDataset + -- * Annotations + , Location, Head, Fill + , arrow + , oval + , rect + , glyph + , text + , cairo + , withAnnotations -- ** Plot type , setSeriesType , setAllSeriesTypes diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot.hs b/lib/Graphics/Rendering/Plot/Figure/Plot.hs --- a/lib/Graphics/Rendering/Plot/Figure/Plot.hs +++ b/lib/Graphics/Rendering/Plot/Figure/Plot.hs @@ -30,6 +30,15 @@ , D.hist , D.candle, D.whisker , setDataset + -- * Annotations + , Location, Head, Fill + , AN.arrow + , AN.oval + , AN.rect + , AN.glyph + , AN.text + , AN.cairo + , withAnnotations -- ** Plot type , setSeriesType , setAllSeriesTypes @@ -88,6 +97,7 @@ import qualified Graphics.Rendering.Plot.Figure.Plot.Data as D import qualified Graphics.Rendering.Plot.Figure.Plot.Axis as AX import qualified Graphics.Rendering.Plot.Figure.Plot.Legend as L +import qualified Graphics.Rendering.Plot.Figure.Plot.Annotation as AN ----------------------------------------------------------------------------- @@ -137,6 +147,11 @@ ----------------------------------------------------------------------------- +withAnnotations :: Annote () -> Plot () +withAnnotations = annoteInPlot + +----------------------------------------------------------------------------- + -- | clear the axes of a subplot clearAxes :: Plot () clearAxes = modify $ \s -> s { _axes = [] } @@ -222,7 +237,7 @@ findMinMax :: Abscissae -> Ordinates -> (Double,Double) findMinMax AbsFunction (OrdFunction _ f _) = let v = mapVector f (linspace 100 (-1,1)) in (minElement v,maxElement v) -findMinMax (AbsPoints x) (OrdFunction _ f _) = let v = mapVector f x +findMinMax (AbsPoints _ x) (OrdFunction _ f _) = let v = mapVector f x in (minElement v,maxElement v) -- what if errors go beyond plot? findMinMax _ (OrdPoints _ y _) = let o = getOrdData y @@ -230,7 +245,7 @@ abscMinMax :: Abscissae -> (Double,Double) abscMinMax AbsFunction = defaultXAxisSideLowerRange -abscMinMax (AbsPoints x) = (minElement x,maxElement x) +abscMinMax (AbsPoints _ x) = (minElement x,maxElement x) ordDim :: Ordinates -> Int diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot/Annotation.hs b/lib/Graphics/Rendering/Plot/Figure/Plot/Annotation.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Figure/Plot/Annotation.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Figure.Plot.Annotation +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- 'Annotation' operations +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Figure.Plot.Annotation ( + clearAnnotations + , arrow + , oval + , rect + , glyph + , text + , cairo + ) where + +----------------------------------------------------------------------------- + +--import Data.Packed.Vector + +import Control.Monad.State +import Control.Monad.Reader + +import qualified Graphics.Rendering.Cairo as C + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +----------------------------------------------------------------------------- + +lineInAnnote :: Line () -> Annote LineType +lineInAnnote m = do + lo <- asks _lineoptions + let l = execLine m lo defaultLineType + return l + +pointInAnnote :: Point () -> Annote PointType +pointInAnnote m = do + po <- asks _pointoptions + let p = execPoint m po defaultPointType + return p + +barInAnnote :: Bar () -> Annote BarType +barInAnnote m = do + bo <- asks _baroptions + let b = execBar m bo defaultBarType + return b + +textInAnnote :: Text () -> Annote TextEntry +textInAnnote m = do + to <- asks _textoptions + let t = execText m to NoText + return t + +----------------------------------------------------------------------------- + +-- | clear annotations +clearAnnotations :: Annote () +clearAnnotations = put [] + +-- | add an arrow +arrow :: Head -> Location -> Location -> Line () -> Annote () +arrow h vs vf m = do + l <- lineInAnnote m + modify $ \s -> (AnnArrow h l vs vf) : s + +-- | add an oval +oval :: Fill -> Location -> Location -> Bar () -> Annote () +oval p c e m = do + b <- barInAnnote m + modify $ \s -> (AnnOval p b c e) : s + +-- | add a rectangle +rect :: Fill -> Location -> Location -> Bar () -> Annote () +rect p rs rf m = do + b <- barInAnnote m + modify $ \s -> (AnnRect p b rs rf) : s + +-- | add a rectangle +glyph :: Location -> Point () -> Annote () +glyph l m = do + p <- pointInAnnote m + modify $ \s -> (AnnGlyph p l) : s + +-- | add text +text :: Location -> Text () -> Annote () +text l m = do + t <- textInAnnote m + modify $ \s -> (AnnText t l) : s + +-- | add a cairo render that takes the bounding box (in user coordinates) +-- as an argument +cairo :: (Double -> Double -> Double -> Double -> C.Render ()) -> Annote () +cairo r = modify $ \s -> (AnnCairo r) : s + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs b/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs --- a/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs +++ b/lib/Graphics/Rendering/Plot/Figure/Plot/Data.hs @@ -40,7 +40,7 @@ ----------------------------------------------------------------------------- ---import Data.Packed.Vector +import Data.Packed.Vector import Data.Maybe @@ -49,6 +49,7 @@ import Control.Monad.State import Control.Monad.Reader import Control.Monad.Supply +import Control.Monad.Maybe import Graphics.Rendering.Plot.Types import Graphics.Rendering.Plot.Figure.Line @@ -518,7 +519,7 @@ toAbscissae :: Abscissa a => [a] -> [Abscissae] toAbscissae = map toAbscissa -instance Abscissa Series where toAbscissa s = AbsPoints s +instance Abscissa Series where toAbscissa s = AbsPoints (isMonotoneIncreasing s) s class Ordinate a where toOrdinate :: a -> Ordinates @@ -891,6 +892,18 @@ setDataSeries d = do ds <- toDataSeries d put ds + +----------------------------------------------------------------------------- + +monoStep :: Double -> MaybeT (State Double) () +monoStep d = do + dp <- get + when (d < dp) (fail "negative difference") + put d +{-# INLINE monoStep #-} + +isMonotoneIncreasing :: Vector Double -> Bool +isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (dim v -1) v))) (v @> 0) ----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Render/Plot.hs b/lib/Graphics/Rendering/Plot/Render/Plot.hs --- a/lib/Graphics/Rendering/Plot/Render/Plot.hs +++ b/lib/Graphics/Rendering/Plot/Render/Plot.hs @@ -51,6 +51,7 @@ import Graphics.Rendering.Plot.Render.Plot.Axis import Graphics.Rendering.Plot.Render.Plot.Data import Graphics.Rendering.Plot.Render.Plot.Legend +import Graphics.Rendering.Plot.Render.Plot.Annotation --import qualified Text.Printf as Printf @@ -122,8 +123,4 @@ ----------------------------------------------------------------------------- -renderAnnotations :: Ranges -> [Annotation] -> Render () -renderAnnotations _ _ = return () - ------------------------------------------------------------------------------ diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Annotation.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Annotation.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Annotation.hs @@ -0,0 +1,136 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Plot.Annotation +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Plot.Annotation ( + -- * Rendering + renderAnnotations + ) where + +----------------------------------------------------------------------------- + +import qualified Graphics.Rendering.Cairo as C + +import Control.Monad.Reader +import Control.Monad.State + +import Graphics.Rendering.Plot.Types +import Graphics.Rendering.Plot.Defaults + +import Graphics.Rendering.Plot.Figure.Text + +import Graphics.Rendering.Plot.Render.Types +import Graphics.Rendering.Plot.Render.Text +import Graphics.Rendering.Plot.Render.Plot.Glyph +import Graphics.Rendering.Plot.Render.Plot.Format + +import Prelude hiding(min,max) +import qualified Prelude(max) + +----------------------------------------------------------------------------- + +renderAnnotations :: Ranges -> Annotations -> Render () +renderAnnotations r an = do + (BoundingBox x y w h) <- get + let (xsc,xmin',xmax') = getRanges XAxis Lower r + let (xmin,xmax) = if xsc == Log then (logBase 10 xmin',logBase 10 xmax') else (xmin',xmax') + let xscale = w/(xmax-xmin) + cairo $ C.save + let (yscl,yminl',ymaxl') = getRanges YAxis Lower r + let (yminl,ymaxl) = if yscl == Log then (logBase 10 yminl',logBase 10 ymaxl') else (yminl',ymaxl') + let yscalel = h/(ymaxl-yminl) + -- transform to data coordinates + cairo $ do + C.translate x (y+h) + C.scale xscale yscalel + C.translate (-xmin) yminl + flipVertical + put (BoundingBox (-xmin) (yminl) (xmax-xmin) (ymaxl-yminl)) + mapM_ (renderAnnotation xscale yscalel) an + put (BoundingBox x y w h) + cairo $ C.restore + +----------------------------------------------------------------------------- + +renderAnnotation :: Double -> Double -> Annotation -> Render () +renderAnnotation xsc ysc (AnnArrow h lt (x1,y1) (x2,y2)) = do + formatLineSeries lt xsc ysc + cairo $ do + C.moveTo x1 y1 + C.lineTo x2 y2 + C.stroke + when h (do + C.moveTo x2 y2 + let theta = atan2 (y2-y1) (x2-x1) + lw <- C.getLineWidth + let ln = lw*10 + cx = x2 - ln * cos theta + cy = y2 - ln * sin theta + xl = cx + (ln/2) * sin (theta + pi/2) + yl = cy + (ln/2) * cos (theta + pi/2) + xu = cx + (ln/2) * sin (theta - pi/2) + yu = cy + (ln/2) * cos (theta - pi/2) + C.lineTo xl yl + C.lineTo xu yu + C.closePath + C.fill + ) + C.stroke +renderAnnotation xsc ysc (AnnOval f b (x1,y1) (x2,y2)) = do + (_,bc,c) <- formatBarSeries b xsc ysc + let width = x2 - x1 + height = y2 - y1 + x = x1 + width/2 + y = y1 + height/2 + cairo $ do + C.save + setColour c + C.translate (x + width / 2) (y + height / 2) + C.scale (1 / (height / 2)) (1 / (width / 2)) + C.arc 0 0 1 0 (2 * pi) + C.restore + C.strokePreserve + when f (do + setColour bc + C.fill) + C.newPath +renderAnnotation xsc ysc (AnnRect f b (x1,y1) (x2,y2)) = do + (_,bc,c) <- formatBarSeries b xsc ysc + cairo $ do + C.save + setColour c + C.rectangle x1 y1 x2 y2 + C.restore + C.strokePreserve + when f (do + setColour bc + C.fill) + C.newPath +renderAnnotation xsc ysc (AnnGlyph pt (x1,y1)) = do + (pw,g) <- formatPointSeries pt xsc ysc + cairo $ do + C.moveTo x1 y1 + renderGlyph xsc ysc pw g +renderAnnotation xsc ysc (AnnText te (x1,y1)) = do +-- (x,y) <- cairo $ C.userToDevice x1 y1 + cairo $ do + C.save + C.scale (recip xsc) (recip (-ysc)) + _ <- renderText te TRight TTop (x1*xsc) (y1*ysc) + cairo $ C.restore + return () +renderAnnotation _ _ (AnnCairo r) = do + (BoundingBox x y w h) <- get + cairo $ r x y w h + +----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs --- a/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Axis.hs @@ -46,6 +46,24 @@ ----------------------------------------------------------------------------- +moveTo :: Double -> Double -> C.Render () +moveTo x y = do + lw <- C.getLineWidth + let (x',y') = if lw >= 1 && (round lw `mod` 2 == (0 :: Int)) + then (fromIntegral $ (round x :: Int),fromIntegral $ (round y :: Int)) + else ((((fromIntegral $ (round x :: Int))*2)+1)/2,(((fromIntegral $ (round y :: Int))*2)+1)/2) + C.moveTo x' y' + +lineTo :: Double -> Double -> C.Render () +lineTo x y = do + lw <- C.getLineWidth + let (x',y') = if lw >= 1 && (round lw `mod` 2 == (0 :: Int)) + then (fromIntegral $ (round x :: Int),fromIntegral $ (round y :: Int)) + else ((((fromIntegral $ (round x :: Int))*2)+1)/2,(((fromIntegral $ (round y :: Int))*2)+1)/2) + C.lineTo x' y' + +----------------------------------------------------------------------------- + addPadding :: Padding -> Padding -> Padding addPadding (Padding l0 r0 b0 t0) (Padding l1 r1 b1 t1) = Padding (l0+l1) (r0+r1) (b0+b1) (t0+t1) @@ -230,11 +248,8 @@ renderAxis r (Axis ax sd lt min maj tf _) = do cairo $ setLineStyle lt + renderAxisTicks r ax sd min maj tf renderAxisLine r ax sd - cairo $ do - lw' <- C.getLineWidth - C.setLineWidth (lw'/2) - renderAxisTicks r ax sd min maj tf return () lowerRange :: Either Range (Range,Range) -> Range @@ -246,40 +261,52 @@ let (Range _ min max) = lowerRange yr (BoundingBox x y w h) <- get cairo $ do - C.moveTo x (y+h*((v-min)/(max-min))+0.5) - C.lineTo (x+w) (y+h*((v-min)/(max-min))+0.5) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x-lw) (y+h*((v-min)/(max-min))) + lineTo (x+w+lw) (y+h*((v-min)/(max-min))) + C.stroke renderAxisLine (Ranges xr _) YAxis (Value v) = do let (Range _ min max) = lowerRange xr (BoundingBox x y w h) <- get cairo $ do - C.moveTo (x+w*((v-min)/(max-min))+0.5) y - C.lineTo (x+w*((v-min)/(max-min))+0.5) (y+h) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x+w*((v-min)/(max-min))) (y-lw) + lineTo (x+w*((v-min)/(max-min))) (y+h+lw) + C.stroke renderAxisLine _ XAxis (Side Lower) = do (BoundingBox x y w h) <- get cairo $ do - C.moveTo x (y+h+0.5) - C.lineTo (x+w) (y+h+0.5) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x-lw) (y+h) + lineTo (x+w+lw) (y+h) + C.stroke renderAxisLine _ XAxis (Side Upper) = do (BoundingBox x y w _) <- get cairo $ do - C.moveTo x (y+0.5) - C.lineTo (x+w) (y+0.5) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x-lw) (y) + lineTo (x+w+lw) (y) + C.stroke renderAxisLine _ YAxis (Side Lower) = do (BoundingBox x y _ h) <- get cairo $ do - C.moveTo (x+0.5) y - C.lineTo (x+0.5) (y+h) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x) (y-lw) + lineTo (x) (y+h+lw) + C.stroke renderAxisLine _ YAxis (Side Upper) = do (BoundingBox x y w h) <- get cairo $ do - C.moveTo (x+w+0.5) (y) - C.lineTo (x+w+0.5) (y+h) - C.stroke + lw' <- C.getLineWidth + let lw = lw'/2 + moveTo (x+w) (y-lw) + lineTo (x+w) (y+h+lw) + C.stroke tickPosition :: Scale -> Double -> Double -> Int -> [(Double,Double)] tickPosition sc min max n = let pos = map (\x -> min + (max-min)*(x)/(fromIntegral (n-1))) (take n [(0 :: Double)..]) @@ -364,42 +391,44 @@ (x1,y1,x2,y2) = case xa of XAxis -> case sd of (Side Lower) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,y+h,xt p+0.5,y+h-tl) + in (xt p,y+h,xt p,y+h-tl) (Side Upper) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,y,xt p+0.5,y+tl) - (Value v) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,v-tl,xt p+0.5,v+tl) + in (xt p,y,xt p,y+tl) + (Value v') -> let xt x' = x + (x'-min)*w/(max-min) + in (xt p,v'-tl,xt p,v'+tl) YAxis -> case sd of (Side Lower) -> let yt y' = (y+h) - (y'-min)*h/(max-min) - in (x,yt p+0.5,x+tl,yt p+0.5) + in (x,yt p,x+tl,yt p) (Side Upper) -> let yt y' = (y+h) - (y'-min)*h/(max-min) - in (x+w,yt p+0.5,x+w-tl,yt p+0.5) - (Value v) -> let yt y' = (y + h) - (y'-min)*h/(max-min) - in (v-tl,yt p+0.5,v+tl,yt p+0.5) - C.moveTo x1 y1 - C.lineTo x2 y2 + in (x+w,yt p,x+w-tl,yt p) + (Value v') -> let yt y' = (y + h) - (y'-min)*h/(max-min) + in (v'-tl,yt p,v'+tl,yt p) + moveTo x1 y1 + lineTo x2 y2 C.stroke when gl (do let (x3,y3,x4,y4) = case xa of XAxis -> case sd of (Side Lower) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,y,xt p+0.5,y+h) + in (xt p,y,xt p,y+h) (Side Upper) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,y,xt p+0.5,y+h) + in (xt p,y,xt p,y+h) (Value _) -> let xt x' = x + (x'-min)*w/(max-min) - in (xt p+0.5,y,xt p+0.5,y+h) + in (xt p,y,xt p,y+h) YAxis -> case sd of (Side Lower) -> let yt y' = (y+h) - (y'-min)*h/(max-min) - in (x,yt p+0.5,x+w,yt p+0.5) + in (x,yt p,x+w,yt p) (Side Upper) -> let yt y' = (y+h) - (y'-min)*h/(max-min) - in (x,yt p+0.5,x+w,yt p+0.5) + in (x,yt p,x+w,yt p) (Value _) -> let yt y' = (y + h) - (y'-min)*h/(max-min) - in (x,yt p+0.5,x+w,yt p+0.5) + in (x,yt p,x+w,yt p) C.save - C.setDash [2,2] 0 - C.setSourceRGBA 0 0 0 0.6 - C.moveTo x3 y3 - C.lineTo x4 y4 + lw <- C.getLineWidth + C.setLineWidth (lw/2) + C.setDash [4,4] 0 + C.setSourceRGBA 0 0 0 0.5 + moveTo x3 y3 + lineTo x4 y4 C.stroke C.restore) let majlab = case sd of diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs --- a/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Data.hs @@ -49,7 +49,9 @@ import Graphics.Rendering.Plot.Types import Graphics.Rendering.Plot.Render.Types +import Graphics.Rendering.Plot.Render.Plot.Format import Graphics.Rendering.Plot.Render.Plot.Glyph +import Graphics.Rendering.Plot.Render.Plot.Annotation import Prelude hiding(min,max,abs) import qualified Prelude @@ -67,12 +69,6 @@ | v @> n <= x = n | otherwise = findMaxIdx v x (n-1) min -flipVerticalMatrix :: CM.Matrix -flipVerticalMatrix = CM.Matrix 1 0 0 (-1) 0 0 - -flipVertical :: C.Render () -flipVertical = C.transform flipVerticalMatrix - ----------------------------------------------------------------------------- greySurfaceFromMatrix :: C.SurfaceData Int Word8 -> Surface -> Int -> Int -> Int -> IO () @@ -89,10 +85,10 @@ B.unsafeWrite s si e) $ zip (repeat ri) [0..((c*c')-1)]) [0..((r*r')-1)] ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- renderData :: Ranges -> DataSeries -> Render () -renderData _ (DS_Surf m) = do +renderData _ (DS_Surf m) = do (BoundingBox x y w h) <- get let r = rows m c = cols m @@ -156,7 +152,8 @@ C.scale xscale yscaleu C.translate xmin yminu flipVertical - mapM_ (renderSeries xsc yscu xmin xmax xscale yscaleu) ups) + mapM_ (renderSeries xsc yscu xmin xmax xscale yscaleu) ups + cairo $ C.restore) -- could filter annotations as well return () @@ -168,32 +165,32 @@ (OrdFunction _ f _) -> do (BoundingBox _ _ w _) <- get let t = linspace (round w) (xmin,xmax) - return $ Left [(t,mapVector f t)] + return $ Left [((True,t),mapVector f t)] (OrdPoints _ (Plain o') _) -> do let t = case abs of AbsFunction -> if isHist d - then fromList [0.0..(fromIntegral $ dim o')] - else fromList [1.0..(fromIntegral $ dim o')] - AbsPoints t' -> t' + then (True,fromList [0.0..(fromIntegral $ dim o')]) + else (True,fromList [1.0..(fromIntegral $ dim o')]) + AbsPoints mi t' -> (mi,t') return $ Left [(t,o')] (OrdPoints _ (Error o' (l,h)) _) -> do let t = case abs of AbsFunction -> if isHist d - then fromList [0.0..(fromIntegral $ dim o')] - else fromList [1.0..(fromIntegral $ dim o')] - AbsPoints t' -> t' + then (True,fromList [0.0..(fromIntegral $ dim o')]) + else (True,fromList [1.0..(fromIntegral $ dim o')]) + AbsPoints mi t' -> (mi,t') return $ Left [(t,o'),(t,o'-l),(t,o'+h)] (OrdPoints _ (MinMax o' (Just (l,h))) _) -> do let t = case abs of - AbsFunction -> fromList [1.0..(fromIntegral $ dim l)] - AbsPoints t' -> t' + AbsFunction -> (True,fromList [1.0..(fromIntegral $ dim l)]) + AbsPoints mi t' -> (mi,t') return $ Right [((t,o'),(t,(l,h)))] let dat = case dat' of - Left dat'' → map (\(a,b) -> Left (if xsc == Log then (logBase 10 a) else a - ,if ysc == Log then (logBase 10 b) else b)) dat'' - Right dat''' → map (\((a,(bl,bu)),(c,(dl,du))) → let (a',c') = if xsc == Log then (logBase 10 a,logBase 10 c) else (a,c) - (bl',bu',dl',du') = if ysc == Log then (logBase 10 bl,logBase 10 bu,logBase 10 dl,logBase 10 du) else (bl,bu,dl,du) - in Right ((a',(bl',bu')),(c',(dl',du')))) dat''' + Left dat'' → map (\((m,a),b) -> Left (if xsc == Log then (m,logBase 10 a) else (m,a) + ,if ysc == Log then (logBase 10 b) else b)) dat'' + Right dat''' -> map (\(((m1,a),(bl,bu)),((m2,c),(dl,du))) → let (a',c') = if xsc == Log then (logBase 10 a,logBase 10 c) else (a,c) + (bl',bu',dl',du') = if ysc == Log then (logBase 10 bl,logBase 10 bu,logBase 10 dl,logBase 10 du) else (bl,bu,dl,du) + in Right (((m1,a'),(bl',bu')),((m2,c'),(dl',du')))) dat''' case d of (DecLine lt) -> do formatLineSeries lt xscale yscale @@ -225,9 +222,9 @@ (DecArea lt) -> do formatLineSeries lt xscale yscale let Left hd = head dat - ln = dim $ fst hd - xmin_ix = findMinIdx (fst hd) xmin 0 (ln-1) - x0 = (fst hd) @> xmin_ix + ln = dim $ snd $ fst hd + xmin_ix = findMinIdx (snd $ fst hd) xmin 0 (ln-1) + x0 = (snd $ fst hd) @> xmin_ix y0 = (snd hd) @> xmin_ix mapM_ (\(t',y') -> renderSamples xmin xmax Nothing renderAreaSample (endAreaSample x0 y0) t' y') (map (either id (error "MinMax data")) dat) @@ -238,10 +235,10 @@ (DecHist bt) -> do (bw,bc,c) <- formatBarSeries bt xscale yscale let Left hd = head dat - ln = dim $ fst hd - xmin_ix = findMinIdx (fst hd) xmin 0 (ln-1) - rest v = subVector 1 (dim v - 1) v - x0 = (fst hd) @> xmin_ix + ln = dim $ snd $ fst hd + xmin_ix = findMinIdx (snd $ fst hd) xmin 0 (ln-1) + rest (m,v) = (m,subVector 1 (dim v - 1) v) + x0 = (snd $ fst hd) @> xmin_ix y0 = 0 mapM_ (\(t',y') -> renderSamples xmin xmax (Just $ C.moveTo x0 y0) (renderHistSample bw bc c) endHistSample (rest t') y') (map (either id (error "MinMax data")) dat) @@ -265,59 +262,21 @@ ----------------------------------------------------------------------------- -formatLineSeries' :: [Dash] -> LineWidth -> Color -> C.Render () -formatLineSeries' ds lw c = do - setDashes ds - C.setLineWidth lw - setColour c - -formatLineSeries :: LineType -> Double -> Double -> Render () -formatLineSeries NoLine _ _ = error "line format of NoLine in a line series" -formatLineSeries (ColourLine c) xscale yscale = do - (LineOptions ds lw) <- asks (_lineoptions . _renderoptions) - cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c -formatLineSeries (TypeLine (LineOptions ds lw) c) xscale yscale = cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c - -formatPointSeries' :: Color -> C.Render () -formatPointSeries' = setColour - -formatPointSeries :: PointType -> Double -> Double -> Render (LineWidth,Glyph) -formatPointSeries (FullPoint (PointOptions pz c) g) _ _ = do - cairo $ formatPointSeries' c - return (pz,g) - -formatBarSeries' :: LineWidth -> C.Render () -formatBarSeries' lw = C.setLineWidth lw - -formatBarSeries :: BarType -> Double -> Double -> Render (Width,Color,Color) -formatBarSeries (ColourBar c) xscale yscale = do - let sc = (xscale+yscale)/2 - (BarOptions bw lw bc) <- asks (_baroptions . _renderoptions) - cairo $ formatBarSeries' (lw/sc) - return (bw/sc,c,bc) -formatBarSeries (TypeBar (BarOptions bw lw bc) c) xscale yscale = do - let sc = (xscale+yscale)/2 - cairo $ formatBarSeries' (lw/sc) - return (bw/sc,c,bc) - ------------------------------------------------------------------------------ - renderSamples :: Double -> Double -> Maybe (C.Render ()) -> (Double -> Double -> C.Render ()) -> C.Render () - -> Vector Double -> Vector Double -> Render () -renderSamples xmin xmax s f e t y = do + -> (Bool,Vector Double) -> Vector Double -> Render () +renderSamples xmin xmax s f e (mono,t) y = do (BoundingBox _ _ w _) <- get let ln = dim t - m = isMonotoneIncreasing t - (xmin_ix,xmax_ix,num_pts) = if m + (xmin_ix,xmax_ix,num_pts) = if mono then (findMinIdx t xmin 0 (ln-1) ,findMaxIdx t xmax (ln-1) 0 ,xmax_ix - xmin_ix + 1) else (0,ln-1,ln) diff'' = floor $ (fromIntegral num_pts)/w diff' = if diff'' <= 1 then 1 else diff'' - diff = if m then diff' else 1 + diff = if mono then diff' else 1 cairo $ do case s of Nothing -> C.moveTo (t @> xmin_ix) (y @> xmin_ix) @@ -334,19 +293,18 @@ renderMinMaxSamples :: Double -> Double -> Maybe (C.Render ()) -> (Double -> (Double,Double) -> C.Render ()) -> C.Render () - -> Vector Double -> (Vector Double,Vector Double) -> Render () -renderMinMaxSamples xmin xmax s f e t y = do + -> (Bool,Vector Double) -> (Vector Double,Vector Double) -> Render () +renderMinMaxSamples xmin xmax s f e (mono,t) y = do (BoundingBox _ _ w _) <- get let ln = dim t - m = isMonotoneIncreasing t - (xmin_ix,xmax_ix,num_pts) = if m + (xmin_ix,xmax_ix,num_pts) = if mono then (findMinIdx t xmin 0 (ln-1) ,findMaxIdx t xmax (ln-1) 0 ,xmax_ix - xmin_ix + 1) else (0,ln-1,ln) diff'' = floor $ (fromIntegral num_pts)/w diff' = if diff'' <= 1 then 1 else diff'' - diff = if m then diff' else 1 + diff = if mono then diff' else 1 cairo $ do case s of Nothing -> C.moveTo (t @> xmin_ix) ((fst $ y) @> xmin_ix) @@ -486,18 +444,6 @@ endWhiskerSample :: C.Render () endWhiskerSample = return () - ------------------------------------------------------------------------------ - -monoStep :: Double -> MaybeT (State Double) () -monoStep d = do - dp <- get - when (d < dp) (fail "negative difference") - put d -{-# INLINE monoStep #-} - -isMonotoneIncreasing :: Vector Double -> Bool -isMonotoneIncreasing v = maybe False (\_ -> True) $ evalState (runMaybeT $ (mapVectorM_ monoStep (subVector 1 (dim v -1) v))) (v @> 0) ----------------------------------------------------------------------------- diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Format.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Format.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Format.hs @@ -0,0 +1,71 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Plot.Render.Plot.Data +-- Copyright : (c) A. V. H. McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : haskell.vivian.mcphail gmail com +-- Stability : provisional +-- Portability : portable +-- +-- Rendering 'Figure's +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Plot.Render.Plot.Format ( + formatLineSeries + , formatPointSeries + , formatBarSeries + ) where + +----------------------------------------------------------------------------- + +import qualified Graphics.Rendering.Cairo as C + +import Graphics.Rendering.Plot.Types + +import Graphics.Rendering.Plot.Render.Types + +import Control.Monad.Reader + +----------------------------------------------------------------------------- + +formatLineSeries' :: [Dash] -> LineWidth -> Color -> C.Render () +formatLineSeries' ds lw c = do + setDashes ds + C.setLineWidth lw + setColour c + +formatLineSeries :: LineType -> Double -> Double -> Render () +formatLineSeries NoLine _ _ = error "line format of NoLine in a line series" +formatLineSeries (ColourLine c) xscale yscale = do + (LineOptions ds lw) <- asks (_lineoptions . _renderoptions) + cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c +formatLineSeries (TypeLine (LineOptions ds lw) c) xscale yscale = cairo $ formatLineSeries' ds ((lw)/(xscale+yscale)) c + +formatPointSeries' :: Color -> C.Render () +formatPointSeries' = setColour + +formatPointSeries :: PointType -> Double -> Double -> Render (LineWidth,Glyph) +formatPointSeries (FullPoint (PointOptions pz c) g) _ _ = do + cairo $ formatPointSeries' c + return (pz,g) + +formatBarSeries' :: LineWidth -> C.Render () +formatBarSeries' lw = C.setLineWidth lw + +formatBarSeries :: BarType -> Double -> Double -> Render (Width,Color,Color) +formatBarSeries (ColourBar c) xscale yscale = do + let sc = (xscale+yscale)/2 + (BarOptions bw lw bc) <- asks (_baroptions . _renderoptions) + cairo $ formatBarSeries' (lw/sc) + return (bw/sc,c,bc) +formatBarSeries (TypeBar (BarOptions bw lw bc) c) xscale yscale = do + let sc = (xscale+yscale)/2 + cairo $ formatBarSeries' (lw/sc) + return (bw/sc,c,bc) + +----------------------------------------------------------------------------- + + diff --git a/lib/Graphics/Rendering/Plot/Render/Plot/Glyph.hs b/lib/Graphics/Rendering/Plot/Render/Plot/Glyph.hs --- a/lib/Graphics/Rendering/Plot/Render/Plot/Glyph.hs +++ b/lib/Graphics/Rendering/Plot/Render/Plot/Glyph.hs @@ -32,7 +32,7 @@ renderGlyph xscale yscale pz g = do C.save C.scale (pz / xscale) (pz / yscale) - C.setLineWidth 1 + C.setLineWidth pz renderGlyph' g C.restore where renderGlyph' Box = renderGlyphBox diff --git a/lib/Graphics/Rendering/Plot/Render/Types.hs b/lib/Graphics/Rendering/Plot/Render/Types.hs --- a/lib/Graphics/Rendering/Plot/Render/Types.hs +++ b/lib/Graphics/Rendering/Plot/Render/Types.hs @@ -32,6 +32,7 @@ --import qualified Data.Array.IArray as A import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as CM import qualified Graphics.Rendering.Pango as P import Control.Monad.Reader @@ -208,6 +209,15 @@ return g ----------------------------------------------------------------------------- + +flipVerticalMatrix :: CM.Matrix +flipVerticalMatrix = CM.Matrix 1 0 0 (-1) 0 0 + +flipVertical :: C.Render () +flipVertical = C.transform flipVerticalMatrix + +----------------------------------------------------------------------------- + diff --git a/lib/Graphics/Rendering/Plot/Types.hs b/lib/Graphics/Rendering/Plot/Types.hs --- a/lib/Graphics/Rendering/Plot/Types.hs +++ b/lib/Graphics/Rendering/Plot/Types.hs @@ -29,6 +29,7 @@ import qualified Data.Array.IArray as A +import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Pango as P import Control.Monad.State @@ -125,21 +126,33 @@ ----------------------------------------------------------------------------- -type Length = Double type Location = (Double,Double) type Orientation = Double -- angle -type Arrow = Bool +type Head = Bool +type Fill = Bool +data AnnoteType = Arrow | Glyph | Text | Oval | Rectangle | Cairo + -- extra glyphs and so on that can be put in a chart -data AnnoteType = AT_Text TextEntry - | AT_Glyph Glyph - | AT_Arrow Arrow LineOptions Length +data Annotation = AnnArrow Head LineType Location Location + | AnnOval Fill BarType Location Location + | AnnRect Fill BarType Location Location + | AnnGlyph PointType Location + | AnnText TextEntry Location --Orientation + | AnnCairo (Double -> Double -> Double -> Double -> C.Render ()) -data Annotation = Annotation AnnoteType Location Orientation Color type Annotations = [Annotation] ----------------------------------------------------------------------------- +newtype Annote a = FN { runAnnote :: ReaderT Options (State Annotations) a} + deriving(Monad, MonadReader Options, MonadState Annotations) + +execAnnote :: Annote a -> Options -> Annotations -> Annotations +execAnnote m r = execState (runReaderT (runAnnote m) r) + +----------------------------------------------------------------------------- + data Scale = Linear | Log deriving(Eq) data Range = Range { _range_scale :: Scale, _range_min :: Double, _range_max :: Double } @@ -267,8 +280,10 @@ getMinMaxData (MinMax o Nothing) = Left o getMinMaxData (MinMax o (Just e)) = Right (o,e) +type MonotoneIncreasing = Bool + data Abscissae = AbsFunction - | AbsPoints Series + | AbsPoints MonotoneIncreasing Series data Ordinates = OrdFunction AxisSide Function (Maybe SeriesLabel) | OrdPoints AxisSide OrdSeries (Maybe SeriesLabel) @@ -424,6 +439,16 @@ legendInPlot :: Legend a -> Plot a legendInPlot m = FP $ lift $ (withReaderT _textoptions . mapReaderT legendInPlot') (runLegend m) + +----------------------------------------------------------------------------- + +annoteInPlot' :: State Annotations a -> State PlotData a +annoteInPlot' m = State $ \s -> let l = _annote s + (a,annote) = runState m l + in (a,s { _annote = annote}) + +annoteInPlot :: Annote a -> Plot a +annoteInPlot m = FP $ lift $ (mapReaderT annoteInPlot') (runAnnote m) ----------------------------------------------------------------------------- diff --git a/plot.cabal b/plot.cabal --- a/plot.cabal +++ b/plot.cabal @@ -1,5 +1,5 @@ Name: plot -Version: 0.1.1.4 +Version: 0.1.2 License: BSD3 License-file: LICENSE Copyright: (c) A.V.H. McPhail 2010 @@ -36,8 +36,11 @@ . * added candle and whisker plots . - Changes in plot 0.2 + Changes in plot 0.1.2 . + * axis join rendering improvement + * added annotations + . Category: Graphics Tested-with: GHC==6.12.1 @@ -80,13 +83,16 @@ Graphics.Rendering.Plot.Figure.Plot.Axis Graphics.Rendering.Plot.Figure.Plot.Data Graphics.Rendering.Plot.Figure.Plot.Legend + Graphics.Rendering.Plot.Figure.Plot.Annotation Graphics.Rendering.Plot.Render.Types Graphics.Rendering.Plot.Render.Text Graphics.Rendering.Plot.Render.Plot Graphics.Rendering.Plot.Render.Plot.Axis Graphics.Rendering.Plot.Render.Plot.Data Graphics.Rendering.Plot.Render.Plot.Legend + Graphics.Rendering.Plot.Render.Plot.Annotation Graphics.Rendering.Plot.Render.Plot.Glyph + Graphics.Rendering.Plot.Render.Plot.Format Control.Monad.Supply ghc-options: -Wall -fno-warn-unused-binds