(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "PLOT")
(il:filecreated " 1-Dec-88 17:31:04" il:{qv}<idl>next>plot-examples.\;6 11342
il:|changes| il:|to:| (il:vars il:plot-examplescoms) (il:functions histogram draw-histogram histogram-make-label histogram-integer-tic-info-fn histogram-integer-interval-fn histogram-change-bins default-n-bins histogram-reset)
il:|previous| il:|date:| " 1-Dec-88 17:15:44" il:{qv}<idl>next>plot-examples.\;5)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:plot-examplescoms)
(il:rpaqq il:plot-examplescoms ((il:coms (il:* il:|;;| "histograms") (il:functions histogram default-n-bins) (il:structures bin-interval) (il:functions draw-histogram make-bin-interval histogram-make-label) (il:functions histogram-tic-info-fn compute-multiple) (il:functions histogram-integer-tic-info-fn histogram-integer-interval-fn) (il:functions histogram-change-bins histogram-reset)) (il:coms (il:* il:|;;| "scatterplots") (il:functions scatter-plot scatter-plot-coordinates)) (eval-when (load) (il:p (export (quote (histogram scatter-plot)) (find-package "PLOT")))) (xcl:file-environments "PLOT-EXAMPLES")))
(il:* il:|;;| "histograms")
(defun histogram (vector &key x-label (y-label "Frequency") (title (if x-label (concatenate (quote string) "Histogram of " (string x-label)) "Histogram")) (shade *shade-3*) (case-ids (ea:genvector (length vector))) region window-title world-extent integer-p dont-open-p) (let* ((plot (make-plot :region region :title window-title)) (bin-menu (copy-menu (default-menu :middle))) (right-menu-items (quote (("Change bins" histogram-change-bins "Change number of bins" (:subitems ("Reset" histogram-reset "Reset range and bin interval to original value")))))) (n (length vector)) (sorted-indices (sort (ea:genvector (length vector)) (function (lambda (x y) (< (aref vector x) (aref vector y)))))) (n-bins (default-n-bins n vector sorted-indices integer-p))) (il:* il:|;;| "Default number of bins set by an heuristic") (il:* il:|;;| "Set up a few key PLOT PROP'S") (setf (plot-prop plot :n) n) (setf (plot-prop plot :n-bins) n-bins) (setf (plot-prop plot :vector) vector) (setf (plot-prop plot :case-ids) case-ids) (setf (plot-prop plot :sorted-indices) sorted-indices) (setf (plot-prop plot :integer-p) integer-p) (setf (plot-prop plot :shade) shade) (il:* il:|;;| "Initialize the histogram so that labels and tics are displayed") (setf-tics-p plot :bottom t t) (setf-tics-p plot :left t t) (setf-plot-label plot :bottom x-label t) (setf-plot-label plot :left y-label t) (setf-plot-label plot :top title t) (il:* il:|;;| "add items to the right menu") (add-plot-menu-items plot :right right-menu-items t) (il:* il:|;;| "Establish a special 'bin' menu") (setf-plot-menu plot :bin-menu bin-menu t) (if integer-p (progn (setf-tic-info-fn plot :x (quote histogram-integer-tic-info-fn) t) (setf-interval-fn plot :x (quote histogram-integer-interval-fn) t)) (setf-tic-info-fn plot :x (quote histogram-tic-info-fn))) (il:* il:|;;| "Draw the histogram based on the PLOT PROP's") (draw-histogram plot dont-open-p) (il:* il:|;;| "Returns a PLOT") plot))
(defun default-n-bins (n vector sorted-indices integer-p) (if integer-p (1+ (- (aref vector (aref sorted-indices (1- n))) (aref vector (aref sorted-indices 0)))) (if (< n 20) (truncate (* 2 (sqrt n))) (truncate (* 10 (log n 10.0))))))
(defstruct (bin-interval (:constructor %make-bin-interval) (:type list)) min max inc n)
(defun draw-histogram (histogram &optional no-update-p) (let* ((shade (plot-prop histogram :shade)) (n (plot-prop histogram :n)) (vector (plot-prop histogram :vector)) (sorted-indices (plot-prop histogram :sorted-indices)) (integer-p (plot-prop histogram :integer-p)) (bin-interval (or (plot-prop histogram :bin-interval) (setf (plot-prop histogram :bin-interval) (make-bin-interval (aref vector (aref sorted-indices 0)) (aref vector (aref sorted-indices (1- n))) (plot-prop histogram :n-bins) integer-p)))) (bin-min (bin-interval-min bin-interval)) (bin-max (bin-interval-max bin-interval)) (bin-inc (bin-interval-inc bin-interval)) (n-bins (bin-interval-n bin-interval))) (il:* il:|;;| "Erase the old image, if any") (setf (plot-objects histogram) (delete-if (function (lambda (object) (plot-object-prop object :histogram-p))) (plot-objects histogram))) (setf (plot-selected-object histogram) nil) (when integer-p (setq bin-min (- bin-min 0.5)) (setq bin-max (+ bin-max 0.5))) (let ((bins (with-collection (do* ((i 0) (bin 0 (1+ bin)) (last-mark bin-min mark) (mark (+ bin-min bin-inc) (+ mark bin-inc))) ((>= bin n-bins)) (let ((frequency (let ((sum 0)) (loop (if (fixnum-eq i n) (return sum)) (let ((value (aref vector (aref sorted-indices i)))) (unless (< value mark) (return sum)) (if (> value last-mark) (incf sum)) (incf i)))))) (if (> frequency 0) (collect (cons mark frequency)))))))) (il:* il:|;;| "Construct the new image") (dolist (bin bins) (let* ((high-mark (car bin)) (low-mark (- high-mark bin-inc)) (frequency (cdr bin)) (rectangle (plot-rectangle histogram low-mark 0 bin-inc frequency :label (histogram-make-label integer-p low-mark high-mark frequency) :texture shade :menu :bin-menu :no-update-p t))) (setf (plot-object-prop rectangle :histogram-p) t) (setf (plot-object-prop rectangle :low-mark) low-mark) (setf (plot-object-prop rectangle :high-mark) high-mark)))) (il:* il:|;;| "Rescale the Histogram") (rescale-plot histogram :both t) (il:* il:|;;| "refresh the image") (unless no-update-p (redraw-plot-window histogram))))
(defun make-bin-interval (min max n-bins integer-p) (if integer-p (let ((n-int (il:add1 (il:idifference max min)))) (if (> n-bins n-int) (%make-bin-interval :min min :max max :inc 1 :n n-int) (let ((mult (ceiling (- max min) n-bins))) (%make-bin-interval :min min :max (+ min (* mult n-bins)) :inc mult :n n-bins)))) (let ((tic-info (scale min max (1+ n-bins)))) (%make-bin-interval :min (ti-min tic-info) :max (ti-max tic-info) :inc (ti-inc tic-info) :n n-bins))))
(defun histogram-make-label (integer-p low-mark high-mark frequency) (if integer-p (let ((i-low-mark (ceiling low-mark)) (i-high-mark (floor high-mark))) (if (eql i-low-mark i-high-mark) (concatenate (quote string) (princ-to-string frequency) " Obs. at " (princ-to-string i-low-mark)) (concatenate (quote string) (princ-to-string frequency) " Obs. between " (princ-to-string i-low-mark) " and " (princ-to-string i-high-mark)))) (concatenate (quote string) (princ-to-string frequency) " Obs. between " (princ-to-string low-mark) " and " (princ-to-string high-mark))))
(defun histogram-tic-info-fn (min max histogram) (let* ((range (- max min)) (bin-interval (plot-prop histogram :bin-interval)) (bin-inc (bin-interval-inc bin-interval)) (n-bins (bin-interval-n bin-interval))) (do ((min-interval-length nil) (min-interval nil) (limit (ceiling range bin-inc)) (multiple (ceiling range (* bin-inc 9)) (1+ multiple))) ((fixnum-eq multiple limit) min-interval) (let* ((interval (compute-multiple min max bin-inc multiple)) (interval-length (ti-length interval))) (when (or (null min-interval) (< interval-length min-interval-length)) (setq min-interval interval) (setq min-interval-length interval-length))))))
(defun compute-multiple (min max inc multiple) (let* ((new-inc (* inc multiple)) (min-mult (floor min new-inc)) (max-mult (ceiling max new-inc))) (make-tic-info :min (* min-mult new-inc) :max (* max-mult new-inc) :inc new-inc :n (1+ (- max-mult min-mult)))))
(defun histogram-integer-tic-info-fn (min max) (let* ((int-max (floor max)) (int-min (ceiling min)) (tic-info (default-tic-info-fn int-min int-max)) (new-min (min int-min (ceiling (ti-min tic-info)))) (inc (ceiling (ti-inc tic-info))) (n-tics (1+ (ceiling (/ (- int-max new-min) (float inc))))) (new-max (+ new-min (* inc (1- n-tics))))) (make-tic-info :min new-min :max new-max :inc inc :n n-tics)))
(defun histogram-integer-interval-fn (min max tic-info) (make-axis-interval :min (- (ti-min tic-info) 0.5) :max (+ (ti-max tic-info) 0.5)))
(defun histogram-change-bins (histogram) (il:* il:|;;;| "Allow the use to specify a range and a bin interval for the histogram") (let* ((prompt-window (plot-prompt-window histogram)) (integer-p (plot-prop histogram :integer-p)) (bin-interval (plot-prop histogram :bin-interval)) (inc (bin-interval-inc bin-interval)) (start (bin-interval-min bin-interval)) (end (bin-interval-max bin-interval)) nbins) (il:* il:|;;| "Have a dialogue with the user") (terpri prompt-window) (setq start (read-from-string (il:promptforword "From " start "Type start point of bin sequence" prompt-window))) (setq start (if integer-p (floor start) (float start))) (setq end (read-from-string (il:promptforword " to " end "Type end point of bin sequence" prompt-window))) (setq end (if integer-p (ceiling end) (float end))) (setq inc (read-from-string (il:promptforword " by " inc "Type an increment" prompt-window))) (setq inc (if integer-p (ceiling inc) (float inc))) (setq nbins (ceiling (/ (- end start) (float inc)))) (setq end (+ start (* inc nbins))) (if integer-p (setq nbins (1+ nbins))) (il:* il:|;;| "Inform the user of what will happen") (print-plot-prompt (concatenate (quote string) "Using: from " (princ-to-string start) " to " (princ-to-string end) " by " (princ-to-string inc)) histogram) (setf (plot-prop histogram :bin-interval) (%make-bin-interval :min start :max end :inc inc :n nbins)) (il:* il:|;;| "redraw the histogram based on the new parameters") (draw-histogram histogram)))
(defun histogram-reset (histogram) (il:* il:|;;;| "Resets the range and bin interval to their original values") (setf (plot-prop histogram :bin-interval) nil) (draw-histogram histogram))
(il:* il:|;;| "scatterplots")
(defun scatter-plot (x-vector y-vector &key x-label y-label (title (if (and x-label y-label) (concatenate (quote string) "Scatterplot of " (string y-label) " vs " (string x-label)) "Scatterplot")) point-labels (symbol *star*) region window-title world-extent dont-open-p) (let ((plot (make-plot :region region :title window-title)) (point-menu-items (quote (("Coordinates" scatter-plot-coordinates "Display point coordinates"))))) (setf-tics-p plot :bottom t t) (setf-tics-p plot :left t t) (setf-plot-label plot :bottom x-label t) (setf-plot-label plot :left y-label t) (setf-plot-label plot :top title t) (setf-plot-menu-items plot :point-menu (append (menu-items (default-menu :middle)) point-menu-items) t) (add-plot-objects (with-collection (dotimes (i (length x-vector)) (collect (make-point (make-position (aref x-vector i) (aref y-vector i)) :symbol symbol :label (and point-labels (aref point-labels i)) :menu :point-menu)))) plot t) (if world-extent (setf-plot-world-extent plot world-extent t) (rescale-plot plot :both t)) (if (null dont-open-p) (open-plot-window plot)) plot))
(defun scatter-plot-coordinates (point plot) (let ((position (point-position point))) (print-plot-prompt (concatenate (quote string) "x = " (float-to-string (position-x position)) ", y = " (float-to-string (position-y position))) plot)))
(eval-when (load)
(export (quote (histogram scatter-plot)) (find-package "PLOT"))
)
(xcl:define-file-environment "PLOT-EXAMPLES" :package "PLOT" :compiler :compile-file :readtable "XCL")
(il:putprops il:plot-examples il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop