-- | -- Module : Simulation.Aivika.Experiment.Chart.FinalHistogramView -- Copyright : Copyright (c) 2012-2014, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.6.3 -- -- The module defines 'FinalHistogramView' that draws a histogram -- by the specified series in final time points collected from different -- simulation runs. -- module Simulation.Aivika.Experiment.Chart.FinalHistogramView (FinalHistogramView(..), defaultFinalHistogramView) where import Control.Monad import Control.Monad.Trans import Control.Concurrent.MVar import Control.Lens import qualified Data.Map as M import Data.IORef import Data.Maybe import Data.Either import Data.Array import Data.Array.IO.Safe import Data.Default.Class import System.IO import System.FilePath import Graphics.Rendering.Chart import Graphics.Rendering.Chart.Backend.Cairo import Simulation.Aivika.Experiment import Simulation.Aivika.Experiment.HtmlWriter import Simulation.Aivika.Experiment.Utils (divideBy, replace) import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotBars) import Simulation.Aivika.Experiment.Histogram import Simulation.Aivika.Experiment.ListSource import Simulation.Aivika.Specs import Simulation.Aivika.Parameter import Simulation.Aivika.Simulation import Simulation.Aivika.Dynamics import Simulation.Aivika.Event import Simulation.Aivika.Signal -- | Defines the 'View' that saves the histogram -- in the PNG file by the specified series in -- final time points collected from different -- simulation runs. data FinalHistogramView = FinalHistogramView { finalHistogramTitle :: String, -- ^ This is a title used in HTML. finalHistogramDescription :: String, -- ^ This is a description used in HTML. finalHistogramWidth :: Int, -- ^ The width of the histogram. finalHistogramHeight :: Int, -- ^ The height of the histogram. finalHistogramFileName :: FileName, -- ^ It defines the file name for the PNG file. -- It may include special variable @$TITLE@. -- -- An example is -- -- @ -- finalHistogramFileName = UniqueFileName \"$TITLE\" \".png\" -- @ finalHistogramPredicate :: Event Bool, -- ^ It specifies the predicate that defines -- when we count data when plotting the histogram. finalHistogramBuild :: [[Double]] -> Histogram, -- ^ Builds a histogram by the specified list of -- data series. finalHistogramSeries :: [String], -- ^ It contains the labels of data plotted -- on the histogram. finalHistogramPlotTitle :: String, -- ^ This is a title used in the histogram. -- It may include special variable @$TITLE@. -- -- An example is -- -- @ -- finalHistogramPlotTitle = \"$TITLE\" -- @ finalHistogramPlotBars :: PlotBars Double Double -> PlotBars Double Double, -- ^ A transformation based on which the plot bar -- is constructed for the series. -- -- Here you can define a colour or style of -- the plot bars. finalHistogramLayout :: Layout Double Double -> Layout Double Double -- ^ A transformation of the plot layout, -- where you can redefine the axes, for example. } -- | The default histogram view. defaultFinalHistogramView :: FinalHistogramView defaultFinalHistogramView = FinalHistogramView { finalHistogramTitle = "Final Histogram", finalHistogramDescription = "It shows a histogram by data gathered in the final time points.", finalHistogramWidth = 640, finalHistogramHeight = 480, finalHistogramFileName = UniqueFileName "$TITLE" ".png", finalHistogramPredicate = return True, finalHistogramBuild = histogram binSturges, finalHistogramSeries = [], finalHistogramPlotTitle = "$TITLE", finalHistogramPlotBars = colourisePlotBars, finalHistogramLayout = id } instance ExperimentView FinalHistogramView where outputView v = let reporter exp dir = do st <- newFinalHistogram v exp dir return ExperimentReporter { reporterInitialise = return (), reporterFinalise = finaliseFinalHistogram st, reporterSimulate = simulateFinalHistogram st, reporterTOCHtml = finalHistogramTOCHtml st, reporterHtml = finalHistogramHtml st } in ExperimentGenerator { generateReporter = reporter } -- | The state of the view. data FinalHistogramViewState = FinalHistogramViewState { finalHistogramView :: FinalHistogramView, finalHistogramExperiment :: Experiment, finalHistogramDir :: FilePath, finalHistogramFile :: IORef (Maybe FilePath), finalHistogramLock :: MVar (), finalHistogramResults :: IORef (Maybe FinalHistogramResults) } -- | The histogram item. data FinalHistogramResults = FinalHistogramResults { finalHistogramNames :: [String], finalHistogramValues :: [ListRef Double] } -- | Create a new state of the view. newFinalHistogram :: FinalHistogramView -> Experiment -> FilePath -> IO FinalHistogramViewState newFinalHistogram view exp dir = do f <- newIORef Nothing l <- newMVar () r <- newIORef Nothing return FinalHistogramViewState { finalHistogramView = view, finalHistogramExperiment = exp, finalHistogramDir = dir, finalHistogramFile = f, finalHistogramLock = l, finalHistogramResults = r } -- | Create new histogram results. newFinalHistogramResults :: [String] -> Experiment -> IO FinalHistogramResults newFinalHistogramResults names exp = do values <- forM names $ \_ -> liftIO newListRef return FinalHistogramResults { finalHistogramNames = names, finalHistogramValues = values } -- | Simulation of the specified series. simulateFinalHistogram :: FinalHistogramViewState -> ExperimentData -> Event (Event ()) simulateFinalHistogram st expdata = do let labels = finalHistogramSeries $ finalHistogramView st providers = experimentSeriesProviders expdata labels input = flip map providers $ \provider -> case providerToDoubleListSource provider of Nothing -> error $ "Cannot represent series " ++ providerName provider ++ " as a source of double values: simulateFinalHistogram" Just input -> listSourceData input names = map providerName providers predicate = finalHistogramPredicate $ finalHistogramView st exp = finalHistogramExperiment st lock = finalHistogramLock st results <- liftIO $ readIORef (finalHistogramResults st) case results of Nothing -> liftIO $ do results <- newFinalHistogramResults names exp writeIORef (finalHistogramResults st) $ Just results Just results -> when (names /= finalHistogramNames results) $ error "Series with different names are returned for different runs: simulateFinalHistogram" results <- liftIO $ fmap fromJust $ readIORef (finalHistogramResults st) let values = finalHistogramValues results h = filterSignalM (const predicate) $ experimentSignalInStopTime expdata handleSignal_ h $ \_ -> do xs <- sequence input liftIO $ withMVar lock $ \() -> forM_ (zip xs values) $ \(x, values) -> addDataToListRef values x return $ return () -- | Plot the histogram after the simulation is complete. finaliseFinalHistogram :: FinalHistogramViewState -> IO () finaliseFinalHistogram st = do let title = finalHistogramTitle $ finalHistogramView st plotTitle = replace "$TITLE" title (finalHistogramPlotTitle $ finalHistogramView st) width = finalHistogramWidth $ finalHistogramView st height = finalHistogramHeight $ finalHistogramView st histogram = finalHistogramBuild $ finalHistogramView st bars = finalHistogramPlotBars $ finalHistogramView st layout = finalHistogramLayout $ finalHistogramView st results <- readIORef $ finalHistogramResults st case results of Nothing -> return () Just results -> do let names = finalHistogramNames results values = finalHistogramValues results xs <- forM values readListRef let zs = histogramToBars . filterHistogram . histogram $ map filterData xs p = plotBars $ bars $ plot_bars_values .~ zs $ plot_bars_titles .~ names $ def updateAxes = if null zs then let v = AxisVisibility True False False in \l -> layout_top_axis_visibility .~ v $ layout_bottom_axis_visibility .~ v $ layout_left_axis_visibility .~ v $ layout_right_axis_visibility .~ v $ l else id chart = layout . updateAxes $ layout_title .~ plotTitle $ layout_plots .~ [p] $ def file <- resolveFileName (Just $ finalHistogramDir st) (finalHistogramFileName $ finalHistogramView st) $ M.fromList [("$TITLE", title)] let opts = FileOptions (width, height) PNG renderableToFile opts (toRenderable chart) file when (experimentVerbose $ finalHistogramExperiment st) $ putStr "Generated file " >> putStrLn file writeIORef (finalHistogramFile st) $ Just file -- | Remove the NaN and inifity values. filterData :: [Double] -> [Double] filterData = filter (\x -> not $ isNaN x || isInfinite x) -- | Remove the NaN and inifity values. filterHistogram :: [(Double, a)] -> [(Double, a)] filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x) -- | Convert a histogram to the bars. histogramToBars :: [(Double, [Int])] -> [(Double, [Double])] histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns) -- | Get the HTML code. finalHistogramHtml :: FinalHistogramViewState -> Int -> HtmlWriter () finalHistogramHtml st index = do header st index file <- liftIO $ readIORef (finalHistogramFile st) case file of Nothing -> return () Just f -> writeHtmlParagraph $ writeHtmlImage (makeRelative (finalHistogramDir st) f) header :: FinalHistogramViewState -> Int -> HtmlWriter () header st index = do writeHtmlHeader3WithId ("id" ++ show index) $ writeHtmlText (finalHistogramTitle $ finalHistogramView st) let description = finalHistogramDescription $ finalHistogramView st unless (null description) $ writeHtmlParagraph $ writeHtmlText description -- | Get the TOC item. finalHistogramTOCHtml :: FinalHistogramViewState -> Int -> HtmlWriter () finalHistogramTOCHtml st index = writeHtmlListItem $ writeHtmlLink ("#id" ++ show index) $ writeHtmlText (finalHistogramTitle $ finalHistogramView st)