[bknr-cvs] r1989 - in branches/xml-class-rework/projects/bos: m2 payment-website/images payment-website/images/statistics statistics worldpay-test
bknr at bknr.net
bknr at bknr.net
Sat Oct 14 07:51:44 UTC 2006
Author: hhubner
Date: 2006-10-14 03:51:44 -0400 (Sat, 14 Oct 2006)
New Revision: 1989
Added:
branches/xml-class-rework/projects/bos/payment-website/images/statistics/
branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp
branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp
Removed:
branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl
Modified:
branches/xml-class-rework/projects/bos/m2/m2.lisp
branches/xml-class-rework/projects/bos/statistics/
branches/xml-class-rework/projects/bos/statistics/Makefile
branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl
branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl
branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
Log:
XML statistics generation and batch SVG rendering.
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-14 07:51:44 UTC (rev 1989)
@@ -387,3 +387,6 @@
(make-contract sponsor
(random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30)))
:paidp t))))
+
+
+
\ No newline at end of file
Property changes on: branches/xml-class-rework/projects/bos/payment-website/images/statistics
___________________________________________________________________
Name: svn:ignore
+ *
Property changes on: branches/xml-class-rework/projects/bos/statistics
___________________________________________________________________
Name: svn:ignore
- contracts-by-week.xml
*.svg
+ contracts-by-week.xsl
contracts-by-week.xml
*.svg
Modified: branches/xml-class-rework/projects/bos/statistics/Makefile
===================================================================
--- branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/statistics/Makefile 2006-10-14 07:51:44 UTC (rev 1989)
@@ -1,7 +1,8 @@
BASE_URL = http://192.168.254.132:8080/reports-xml
YEAR = 2005
-LOGIN =
+LOGIN =
+OUTPUT_DIR = ../payment-website/images/statistics
GRAPHICS = contracts-by-week.svg
@@ -18,5 +19,5 @@
.xsl.svg:
xsltproc -o $*.xml $*.xsl '$(BASE_URL)/$*/$(YEAR)$(LOGIN)'
- xsltproc -o $*-$(YEAR).svg buildSVGLineChart.xsl $*.xml
+ xsltproc -o $(OUTPUT_DIR)/$*-$(YEAR).svg buildSVGLineChart.xsl $*.xml
rm $*.xml
\ No newline at end of file
Modified: branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl
===================================================================
--- branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/statistics/buildSVGLineChart.xsl 2006-10-14 07:51:44 UTC (rev 1989)
@@ -21,7 +21,7 @@
<xsl:variable name="minx">
<xsl:value-of select="minx"/>
</xsl:variable>
- <svg width="1200" height="1200" onload="getSVGDoc(evt)" onzoom="ZoomControl()">
+ <svg width="800" height="600" onload="getSVGDoc(evt)" onzoom="ZoomControl()">
<defs>
<g id="star" transform="scale(0.21)">
<polyline points="48,16,16,96,96,48,0,48,80,96">
Modified: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl
===================================================================
--- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.lxsl 2006-10-14 07:51:44 UTC (rev 1989)
@@ -17,17 +17,26 @@
<set title="Contracts" marker-type="triangle" color="green">
<xsl:for-each select="week">
<measure>
- <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue>
+ <xvalue><xsl:value-of select="@week-first-yday"/></xvalue>
<yvalue><xsl:value-of select="@contracts"/></yvalue>
</measure>
</xsl:for-each>
</set>
</sets>
<minx>1</minx>
- <maxx>52</maxx>
+ <maxx>365</maxx>
<miny>0</miny>
<maxy><xsl:value-of select="$max_contracts"/></maxy>
<title>Contracts by week for year <xsl:value-of select="$year"/></title>
+ <xvalues>
+ <xsl:for-each select="month">
+ <xvalue>
+ <value><xsl:value-of select="@start-yday"/></value>
+ <label><xsl:value-of select="@name"/></label>
+ <gridline>true</gridline>
+ </xvalue>
+ </xsl:for-each>
+ </xvalues>
<yvalues>
<loop:for name="i" from="20" to="$max_contracts" step="20">
<yvalue>
Deleted: branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl
===================================================================
--- branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/statistics/contracts-by-week.xsl 2006-10-14 07:51:44 UTC (rev 1989)
@@ -1,49 +0,0 @@
-<?xml version="1.0" encoding="iso-8859-1"?>
-<!--
-
- File generated by translating loops into recursive template calls.
- XSLT Loop Compiler, Version 1.0
- GPL (c) O. Becker
-
- -->
-<xsl:stylesheet xmlns:loop="http://informatik.hu-berlin.de/loop" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0">
- <xsl:output method="xml"/>
-
- <xsl:template match="/response">
- <xsl:variable name="year">
- <xsl:value-of select="substring(/response/week[1]/@key, 1, 4)"/>
- </xsl:variable>
- <xsl:variable name="max_contracts">
- <xsl:for-each select="week">
- <xsl:sort select="@contracts" data-type="number" order="descending"/>
- <xsl:if test="position()=1"><xsl:value-of select="@contracts"/></xsl:if>
- </xsl:for-each>
- </xsl:variable>
- <graphData>
- <sets>
- <set title="Contracts" marker-type="triangle" color="green">
- <xsl:for-each select="week">
- <measure>
- <xvalue><xsl:value-of select="substring(@key, 6)"/></xvalue>
- <yvalue><xsl:value-of select="@contracts"/></yvalue>
- </measure>
- </xsl:for-each>
- </set>
- </sets>
- <minx>1</minx>
- <maxx>52</maxx>
- <miny>0</miny>
- <maxy><xsl:value-of select="$max_contracts"/></maxy>
- <title>Contracts by week for year <xsl:value-of select="$year"/></title>
- <yvalues>
- <xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="20"/><xsl:with-param name="toid4477040" select="$max_contracts"/><xsl:with-param name="stepid4477040" select="20"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template>
- </yvalues>
- </graphData>
- </xsl:template>
-<xsl:template name="for-loop-id4477040"><xsl:param name="i"/><xsl:param name="toid4477040"/><xsl:param name="stepid4477040"/><xsl:param name="year"/><xsl:param name="max_contracts"/>
- <yvalue>
- <value><xsl:value-of select="$i"/></value>
- <label><xsl:value-of select="$i"/></label>
- <gridline>true</gridline>
- </yvalue>
- <xsl:if test="$i+$stepid4477040 <= $toid4477040"><xsl:call-template name="for-loop-id4477040"><xsl:with-param name="i" select="$i + $stepid4477040"/><xsl:with-param name="toid4477040" select="$toid4477040"/><xsl:with-param name="stepid4477040" select="$stepid4477040"/><xsl:with-param name="year" select="$year"/><xsl:with-param name="max_contracts" select="$max_contracts"/></xsl:call-template></xsl:if></xsl:template></xsl:stylesheet>
Modified: branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/worldpay-test/packages.lisp 2006-10-14 07:51:44 UTC (rev 1989)
@@ -2,6 +2,7 @@
(defpackage :worldpay-test
(:use :cl
+ :date-calc
:extensions
:cl-user
:cl-interpol
@@ -11,7 +12,7 @@
:xhtml-generator
:cxml
:puri
- :mime
+ #+(or) :mime
:acl-compat.socket
:acl-compat.mp
:bknr.web
Added: branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/worldpay-test/reports-xml-handler.lisp 2006-10-14 07:51:44 UTC (rev 1989)
@@ -0,0 +1,99 @@
+
+(in-package :worldpay-test)
+
+(enable-interpol-syntax)
+
+(defclass reports-xml-handler (prefix-handler)
+ ())
+
+(defvar *report-generators* (make-hash-table))
+(defvar *contracts-to-process*)
+(defvar *year*)
+(defvar *month-names* '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+
+(defmacro defreport (name arguments &body body)
+ `(setf (gethash ',name *report-generators*) (lambda (, at arguments) , at body)))
+
+(defun contract-year (contract)
+ (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract))
+ year))
+
+(defmethod handle ((handler reports-xml-handler) req)
+ (with-xml-response req
+ (destructuring-bind (name *year* &rest arguments) (decoded-handler-path handler req)
+ (setf *year* (parse-integer *year*))
+ (let ((*contracts-to-process* (sort (remove-if (lambda (contract)
+ (or (not (contract-paidp contract))
+ (and *year*
+ (not (eql *year* (contract-year contract))))))
+ (class-instances 'contract))
+ #'< :key #'contract-date)))
+ (setf name (intern (string-upcase name) :worldpay-test))
+ (apply (or (gethash name *report-generators*)
+ (error "invalid report name ~A" name))
+ arguments)))))
+
+
+(defreport all-contracts ()
+ (dolist (contract *contracts-to-process*)
+ (with-element "contract"
+ (attribute "date-time" (format-date-time (contract-date contract) :xml-style t))
+ (attribute "country" (sponsor-country (contract-sponsor contract)))
+ (attribute "sqm-count" (length (contract-m2s contract))))))
+
+(defun week-of-contract (contract)
+ "Return Week key (YYYY-WW) for given contract."
+ (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract))
+ (multiple-value-bind (week-no week-year)
+ (week-of-year year month date)
+ (when (and (> week-no 50)
+ (eql month 1))
+ ;; If the date falls within the last week of the previous
+ ;; year, we put it into the first week of the current year in
+ ;; order to simplify graphics drawing.
+ (setf week-no 1))
+ (format nil "~A-~A" week-year week-no))))
+
+(defun week-first-yday (contract)
+ "Return the day-of year of the first day of the contract's date"
+ (multiple-value-bind (second minute hour date month year day-of-week is-dst tz) (decode-universal-time (contract-date contract))
+ (max 0 (- (day-of-year year month date) (day-of-week year month date)))))
+
+(defreport contracts-by-week ()
+ (dolist (week-contracts (group-on *contracts-to-process*
+ :test #'equal
+ :key #'week-of-contract))
+ (with-element "week"
+ (attribute "week-first-yday" (week-first-yday (first (cdr week-contracts))))
+ (attribute "key" (first week-contracts))
+ (attribute "contracts" (length (cdr week-contracts)))
+ (attribute "sqms" (apply #'+ (mapcar (lambda (contract) (length (contract-m2s contract))) (cdr week-contracts))))))
+ (dotimes (month 12)
+ (with-element "month"
+ (attribute "number" month)
+ (attribute "name" (nth month *month-names*))
+ (attribute "start-yday" (1- (day-of-year *year* (1+ month) 1))))))
+
+(defreport contract-sizes ()
+ (let ((contract-sizes (make-hash-table :test #'equal))
+ (thresholds '(1 10 30 100 10000000)))
+ (dolist (threshold thresholds)
+ (setf (gethash threshold contract-sizes) 0))
+ (dolist (contract *contracts-to-process*)
+ (dolist (threshold thresholds)
+ (when (<= (length (contract-m2s contract)) threshold)
+ (incf (gethash threshold contract-sizes))
+ (return))))
+ (dolist (threshold thresholds)
+ (with-element "contracts"
+ (attribute "threshold" threshold)
+ (attribute "count" (gethash threshold contract-sizes))))))
+
+(defreport contract-countries ()
+ (dolist (country-contracts (sort (group-on *contracts-to-process*
+ :test #'equal
+ :key (lambda (contract) (sponsor-country (contract-sponsor contract))))
+ #'> :key (lambda (entry) (length (cdr entry)))))
+ (with-element "country"
+ (attribute "code" (car country-contracts))
+ (attribute "contracts" (length (cdr country-contracts))))))
\ No newline at end of file
Added: branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/worldpay-test/rss.lisp 2006-10-14 07:51:44 UTC (rev 1989)
@@ -0,0 +1,21 @@
+(in-package :worldpay-test)
+
+(defmethod rss-item-channel ((item news-item))
+ "news")
+
+(defmethod rss-item-published ((item news-item))
+ (format t "Language: ~A~%" (current-website-language))
+ t)
+
+(defmethod rss-item-title ((item news-item))
+ (news-item-title item (current-website-language)))
+
+(defmethod rss-item-description ((item news-item))
+ (news-item-text item (current-website-language)))
+
+(defmethod rss-item-link ((item news-item))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item)))
+
+(defmethod rss-item-guid ((item news-item))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (current-website-language) (store-object-id item)))
+
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.asd 2006-10-14 07:51:44 UTC (rev 1989)
@@ -28,6 +28,7 @@
(:file "poi-handlers" :depends-on ("web-utils"))
(:file "boi-handlers" :depends-on ("web-utils"))
(:file "contract-handlers" :depends-on ("web-utils"))
+ (:file "reports-xml-handler" :depends-on ("boi-handlers"))
(:file "sponsor-handlers" :depends-on ("web-utils"))
(:file "news-handlers" :depends-on ("web-utils"))
(:file "allocation-area-handlers" :depends-on ("web-utils"))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 07:07:33 UTC (rev 1988)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-14 07:51:44 UTC (rev 1989)
@@ -185,6 +185,7 @@
("/edit-poi-image" edit-poi-image-handler)
("/edit-sponsor" edit-sponsor-handler)
("/contract" contract-handler)
+ ("/reports-xml" reports-xml-handler)
("/complete-transfer" complete-transfer-handler)
("/edit-news" edit-news-handler)
("/make-poi" make-poi-handler)
More information about the Bknr-cvs
mailing list