Commits

Anonymous committed 9c78a70

* define more settings for CalHeatMap widget
* show two instances of the widget on /calendarheatmap

Comments (0)

Files changed (5)

Handler/Handlers.hs

 module Handler.Handlers where
 import           Control.Monad.Random
 import           Data.Aeson
+import           Data.Colour.SRGB
 import           Data.Default             (def)
+import           Data.Monoid
+import qualified Data.Text                as T
 import           Data.Time.Calendar       (fromGregorian)
 import           Data.Time.Clock          (UTCTime (..), addUTCTime,
                                            secondsToDiffTime)
 import           Data.Time.Lens
 import           Import
 import           Yesod.Widgets.CalHeatMap
-
 getCalendarHeatMapR :: Handler Html
 getCalendarHeatMapR = do
-  values <- liftIO $ generateRandomData (1::Double,100) 365
-  widgetId <- newIdent
-  let chSettings = (def CalHeatMapWidgetSettings) { chmData = (CalHeatMapRawData $ generateCalHeatMapData values)
+  oneYearOfDailyValues <- liftIO $ generateRandomData (1::Double,100) 365
+  tenDaysOfHourlyValues <- liftIO $ generateRandomData (1::Double, 100) (24 * 10)
+
+  let dailySettings = (def CalHeatMapWidgetSettings) { chmData = (CalHeatMapRawData $ generateCalHeatMapHourlyData tenDaysOfHourlyValues)
+                                                      , chmDomain = Just Day
+                                                      , chmRange = Just 10
+                                                      , chmLegend = Just $ take 10 [10, 20..]
+                                                      , chmLegendColors = Just (LegendColorsArray [sRGB 0 1 0, sRGB 1 0 0])
+                                                      }
+
+  let weeklySettings = (def CalHeatMapWidgetSettings) { chmData = (CalHeatMapRawData $ generateCalHeatMapData oneYearOfDailyValues)
                                                   , chmDomain = Just Week
                                                   , chmRange = Just (fromInteger $ toInteger $ truncate (365/7))
-                                                  , chmLegend = Just $ take 10  [0, 10..]
+                                                  , chmLegend = Just $ take 10  [10, 20..]
+                                                  , chmLegendColors = Just (LegendColorsObject (lowC, highC) (Just emptyC) Nothing Nothing)
+                                                  , chmLabel = Just (Label Nothing Nothing (Just RotateLeft) Nothing Nothing Nothing)
                                                   }
+
+  let settings = [("hourly display" :: T.Text ,dailySettings), ("daily display", weeklySettings)]
+
+  ids <- mapM (\_ -> newIdent) settings
+  let
+    settingsAndIds = zip settings ids
+    widgets = (map (\((t,s),i) -> [whamlet|<h1>#{t}|] <> widgetCalHeatMap s i) settingsAndIds)
+    allwidgets = mconcat widgets
+  {-
   let widget = widgetCalHeatMap chSettings widgetId
-  defaultLayout $ do [whamlet|^{widget} |]
+  widgetId2 <- newIdent
+  let widget2 = widgetCalHeatMap hourlySettings widgetId2
+  defaultLayout $ do [whamlet|^{widget} ^{widget2}|]-}
+  defaultLayout $ do [whamlet|^{allwidgets}|]
   where
-    getDaysFor d values = map (\(i,_) -> modL hours (+24*i) d) $ zip [1..] values
-    generateCalHeatMapData v = zip (getDaysFor (UTCTime (fromGregorian 2000 01 01) 0) v) v
-
+    someStartDate = UTCTime (fromGregorian 2000 01 01) 0
+    getHoursFor d values = map (\(i, _) -> modL hours (+i) d) $ zip [0..] values
+    getDaysFor d values = map (\(i,_) -> modL hours (+24*i) d) $ zip [0..] values
+    generateCalHeatMapData v = zip (getDaysFor someStartDate v) v
+    generateCalHeatMapHourlyData v = zip (getHoursFor someStartDate v) v
+    lowC = sRGB 0.5 0.5 1
+    highC = sRGB 1 0.5 (0.5 :: Double)
+    emptyC = sRGB 1 1 1
 generateRandomData :: (Random a, MonadRandom m) => (a, a) -> Int -> m [a]
-generateRandomData range count = do
+generateRandomData range n = do
   values <- getRandomRs range
-  return $ take count values
-
-gR :: (RandomGen g) => g-> ([Integer], g)
-gR = do
-  runRand $ generateRandomData (10::Integer,100) 10
-
-
-
+  return $ take n values

Yesod/Widgets/CalHeatMap.hs

 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
-module Yesod.Widgets.CalHeatMap (CalHeatMapWidgetSettings(..), CalHeatMapData(..),Domain (.. ), SubDomainOrientation(..), SubDomain(..), widgetCalHeatMap) where
+module Yesod.Widgets.CalHeatMap (
+  CalHeatMapWidgetSettings(..)
+  , CalHeatMapData(..)
+  , Domain (.. )
+  , SubDomainOrientation(..)
+  , SubDomain(..)
+  , LegendColors(..)
+  , Label(..)
+  , Rotate(..)
+  , Position(..)
+  , Align(..)
+  , widgetCalHeatMap
+  ) where
 
-import qualified Data.Aeson            as J
-import qualified Data.ByteString       as BS
-import qualified Data.ByteString.Lazy  as LBS
-import           Data.Convertible      (convert)
-import           Data.Default          (Default, def)
-import           Data.List             (minimum)
-import           Data.Maybe            (fromJust, isJust)
-import qualified Data.Text             as T
-import           Data.Text.Encoding    (decodeUtf8)
-import           Data.Time.Calendar    (fromGregorian, toGregorian)
-import           Data.Time.Clock       (UTCTime (..), utctDay)
-import           Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
-import           Prelude               (Bool, Double, Int, Maybe (..), Show,
-                                        error, fromEnum, fst, init, map, map,
-                                        min, otherwise, show, toInteger, ($),
-                                        (*), (++))
-import           System.Posix.Types    (EpochTime (..))
-import           Text.Blaze.Html       (Html, preEscapedToHtml)
-import           Yesod                 (julius, whamlet)
-import qualified Yesod                 as Y
+import           Blaze.ByteString.Builder (toLazyByteString)
+import qualified Data.Aeson               as J
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.Lazy     as LBS
+import           Data.Colour              (Colour, opaque)
+import           Data.Convertible         (convert)
+import           Data.CSS                 (toPropBuilder)
+import           Data.Default             (Default, def)
+import           Data.List                (minimum)
+import           Data.Maybe               (fromJust, isJust, isNothing)
+import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8)
+import           Data.Time.Calendar       (fromGregorian, toGregorian)
+import           Data.Time.Clock          (UTCTime (..), utctDay)
+import           Data.Time.Clock.POSIX    (utcTimeToPOSIXSeconds)
+import           Data.Vector              (fromList)
+import           Prelude                  (Bool, Double, Floating, Fractional,
+                                           Int, Maybe (..), RealFrac, Show,
+                                           error, fromEnum, fst, init, map, map,
+                                           min, otherwise, show, toInteger, ($),
+                                           (*), (++), (.))
+import           System.Posix.Types       (EpochTime (..))
+import           Text.Blaze.Html          (Html, preEscapedToHtml)
+import           Yesod                    (julius, whamlet)
+import qualified Yesod                    as Y
 
 utcTimeToEpochTime :: UTCTime -> EpochTime
 utcTimeToEpochTime = convert
 
 data CalHeatMapData = CalHeatMapRawData [(UTCTime, Double)] -- ^ provide raw data
                     | CalHeatMapURIData T.Text -- ^ provide URI to data (might want to optionally pass a yesod route, not sure how it is done yet)
-                    deriving (Show)
+
 
 data Domain = Year
             | Month
             | Week
             | Day
             | Hour
-            deriving (Show)
+
 data SubDomainOrientation = Horizontal | Vertical
-                          deriving (Show)
+
 data SubDomain = SubDomain Domain SubDomainOrientation
                | Minute SubDomainOrientation
-               deriving (Show)
-data CalHeatMapWidgetSettings
+
+data CalHeatMapWidgetSettings c
   = CalHeatMapWidgetSettings { chmData              :: CalHeatMapData -- ^ time serie data source for heat map
                              , chmStartDate         :: Maybe UTCTime -- ^ if Nothing, will be infered from chmData
                              , chmDomain            :: Maybe Domain
                              , chmWeekStartOnMonday :: Maybe Bool
                              , chmRange             :: Maybe Int
                              , chmLegend            :: Maybe [Double]
+                             , chmLegendColors      :: Maybe (LegendColors c)
+                             , chmLabel             :: Maybe Label
                              }
   | JSON J.Value
-  deriving (Show)
 
-instance Default CalHeatMapWidgetSettings where
+data Position = Top
+              | Right
+              | Bottom
+              | Left
+
+data Align = AlignLeft
+           | AlignCenter
+           | AlignRight
+
+data Rotate = RotateLeft
+            | RotateRight
+
+data Label = Label
+             (Maybe Position) -- ^ position: Position of the label, relative to the domain
+             (Maybe Align) -- ^ align: Horizontal align of the domain
+             (Maybe Rotate) -- ^ rotate: Rotation for a vertical label
+             (Maybe Int) -- ^ width: Only used when label is rotated, defines the width of the label
+             (Maybe (Int, Int)) -- ^ offset: More control about label positioning, if the default value does not fit your need, especially when label is rotated, or when using a big font-size
+             (Maybe Int) -- ^ height: Height of the domain label in pixels. By leaving it to null, the label will be set to 2 times the height of the subDomain cell.
+
+data LegendColors a = LegendColorsArray [Colour a]
+                    | LegendColorsObject
+                      (Colour a, Colour a) -- ^ min and max: Color of the smallest and highest values on the legend
+                      (Maybe (Colour a)) -- ^ empty: Color for the dates with value == 0
+                      (Maybe (Colour a)) -- ^ base: Base color of the date cell's
+                      (Maybe (Colour a)) -- ^ overflow: Color for the special value
+
+instance J.ToJSON Position where
+  toJSON p = J.String $ case p of
+    Top -> "top"
+    Right -> "right"
+    Bottom -> "bottom"
+    Left -> "left"
+
+instance J.ToJSON Align where
+  toJSON a = J.String $ case a of
+    AlignLeft -> "left"
+    AlignCenter -> "center"
+    AlignRight -> "right"
+
+instance J.ToJSON Rotate where
+  toJSON r = J.String $ case r of
+    RotateLeft -> "left"
+    RotateRight -> "right"
+
+instance J.ToJSON Label where
+  toJSON (Label position align rotate width offset height) = J.object values
+    where
+      values = positionValue ++ alignValue ++ rotateValue ++ widthValue ++ offsetValue ++ heightValue
+      positionValue = maybeValue "position" position
+      alignValue = maybeValue "align" align
+      rotateValue = maybeValue "rotate" rotate
+      widthValue = maybeValue "width" width
+      offsetValue = case offset of
+        Nothing -> []
+        Just (x,y) -> [("offset", J.object [("x" :: T.Text, J.toJSON x), ("y", J.toJSON y)])]
+      heightValue = maybeValue "height" height
+      maybeValue k v = if isJust v then [(k, J.toJSON $ fromJust v)] else []
+
+
+instance (RealFrac a, Floating a) => J.ToJSON (LegendColors a) where
+  toJSON legend = case legend of
+     LegendColorsArray [] -> J.Null
+     LegendColorsArray v -> J.Array $ fromList $ map (J.String . colourToString) v
+     LegendColorsObject (min, max) e b o -> J.object $ [("min", J.String $ colourToString min), ("max", J.String $ colourToString max)] ++ maybeColourToValue "emtpy" e ++ maybeColourToValue "base" b ++ maybeColourToValue "overflow" o
+     where
+       maybeColourToValue n m = case m of
+         Just colour -> [(n, J.String $ colourToString colour)]
+         Nothing -> []
+
+
+instance Default (CalHeatMapWidgetSettings a) where
   def = CalHeatMapWidgetSettings { chmData = CalHeatMapRawData []
                                  , chmStartDate = Nothing
                                  , chmDomain = Nothing
                                  , chmWeekStartOnMonday = Nothing
                                  , chmRange = Nothing
                                  , chmLegend = Nothing
+                                 , chmLegendColors = Nothing
+                                 , chmLabel = Nothing
                                  }
 --widgetCalHeatMap :: CalHeatMapWidgetSettings -> T.Text -> Y.Widget
 widgetCalHeatMap settings widgetId = do
        if(#{isJust $ chmLegend settings}){
            settings.legend = #{J.toJSON $ chmLegend settings}
        }
+       if(#{isJust $ chmLegendColors settings}){
+           settings.legendColors = #{legendColoursAsJSON}
+       }
+       if(#{isJust $ chmLabel settings}){
+           settings.label = #{J.toJSON $ chmLabel settings}
+       }
        cal.init(settings);
     })();
 |]
     subdomain
       | isJust $ chmSubDomain settings = subdomainToString $ fromJust $ chmSubDomain settings
       | otherwise = subdomainToString $ SubDomain Hour Horizontal
+    legendColoursAsJSON
+      | isNothing $ chmLegendColors settings = J.Null
+      | otherwise = J.toJSON $ fromJust $ chmLegendColors settings
 
 serializeRawData :: [(UTCTime, Double)] -> J.Value
 serializeRawData items = J.object $ map transformToPair items
 lazyToStrictBS :: LBS.ByteString -> BS.ByteString
 lazyToStrictBS x = BS.concat $ LBS.toChunks x
 
+lazyStringToText :: LBS.ByteString -> T.Text
+lazyStringToText v = decodeUtf8 $ lazyToStrictBS v
+
 toUtf8Text :: J.Value -> T.Text
-toUtf8Text v = decodeUtf8 $ lazyToStrictBS $ J.encode $ v
+toUtf8Text v = lazyStringToText $ J.encode v
 
 -- | this is useful to output Aeson's json value in a hamlet template
 toText :: J.Value -> Html
-toText v = preEscapedToHtml $ toUtf8Text $ v
+toText v = preEscapedToHtml $ toUtf8Text v
+
+
+--colourToString :: Colour a -> Builder
+colourToString c = lazyStringToText $ toLazyByteString $ toPropBuilder $ opaque c

templates/homepage.julius

-document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
+document.getElementById(# {toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";

templates/homepage.lucius

 h1 {
     text-align: center
 }
-h2##{aDomId} {
+h2# # {aDomId} {
     color: #990
 }

yesod-widgets.cabal

                  , time-lens
                  , blaze-html
                  , colour
+                 , cascading
+                 , blaze-builder
+                 , vector
 
 executable         yesod-widgets
     if flag(library-only)