Interactive overlays with the Racket Plot Package

current-value-fancy.rkt

#lang racket
(require racket/gui mrlib/snip-canvas plot pict racket/draw)

(define (pie-slice w h angle)
  (define nangle (let ((npi (floor (/ angle (* 2 pi)))))
                   (- angle (* 2 pi npi))))
  (define (draw dc dx dy) (send dc draw-arc dx dy w h (- (/ nangle 2)) (/ nangle 2)))
  (dc draw w h))

(define item-font (send the-font-list find-or-create-font 12 'default 'normal 'normal))
(define background (make-object color% #xff #xf8 #xdc 0.8))

(define (make-tag x y)
  (define p (hc-append
             (text "sin(" item-font)
             (colorize (pie-slice 15 15 x) "black")
             (text ") = " item-font)
             (text (~r y #:precision '(= 2)) item-font)))
  (define r (filled-rounded-rectangle
             (+ (pict-width p) 10) (+ (pict-height p) 10) -0.2
             #:draw-border? #f #:color background))
  (cc-superimpose r p))

(define ((make-current-value-renderer fn) snip event x y)
  (define overlays
    (and x y (eq? (send event get-event-type) 'motion)
         (let ((pict (make-tag x (fn x))))
           (list
            (vrule x #:style 'long-dash)
            (point-pict (vector x y) pict #:anchor 'auto #:point-sym 'none)))))
  (send snip set-overlay-renderers overlays))

(define (make-plot-snip width height)
  (define snip (plot-snip (function sin)
                          #:x-min 0 #:x-max (* 2 pi)
                          #:y-min -1.5 #:y-max 1.5
                          #:width width #:height height))
  (send snip set-mouse-event-callback (make-current-value-renderer sin))
  snip)

(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)

current-value.rkt

#lang racket
(require racket/gui mrlib/snip-canvas plot)

(define ((make-current-value-renderer fn) snip event x y)
  (define overlays
    (and x y (eq? (send event get-event-type) 'motion)
         (list
          (vrule x #:style 'long-dash)
          (point-label (vector x (fn x)) #:anchor 'auto))))
  (send snip set-overlay-renderers overlays))

(define (make-plot-snip width height)
  (define snip  (plot-snip (function sin)
                           #:x-min 0 #:x-max (* 2 pi)
                           #:y-min -1.5 #:y-max 1.5
                           #:width width #:height height))
  (send snip set-mouse-event-callback (make-current-value-renderer sin))
  snip)

(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)

drag-select.rkt

#lang racket
(require racket/gui mrlib/snip-canvas plot)

(define drag-start #f)

(define (drag-selection-callback snip event x y)
  (case (send event get-event-type)
    ((left-down) (set! drag-start x))
    ((left-up) (set! drag-start #f))
    ((motion)
     (define overlays
       (and x drag-start
            (list
             (rectangles (list (vector (ivl drag-start x) (ivl -inf.0 +inf.0)))
                         #:color "blue"
                         #:alpha 0.2)
             (point-label (vector (* 0.5 (+ drag-start x)) 0)
                          (~r (radians->degrees (abs (- x drag-start))) #:precision 1)
                          #:anchor 'center #:point-sym 'none)
             )))
     (send snip set-overlay-renderers overlays))))

(define (make-plot-snip width height)
  (define snip (plot-snip (function sin)
                          #:x-min -5 #:x-max 5
                          #:y-min -1.5 #:y-max 1.5
                          #:width width #:height height))
  (send snip set-mouse-event-callback drag-selection-callback)
  snip)

(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)

histogram.rkt

#lang racket
(require racket/gui mrlib/snip-canvas plot)

(define series1 '(#(Eggs 1.5) #(Bacon 2.5) #(Pancakes 3.5)))
(define series2 '(#(Eggs 1.4) #(Bacon 2.3) #(Pancakes 3.1)))

(define (xposition->histogram-slot xposition
                                   (skip (discrete-histogram-skip))
                                   (gap (discrete-histogram-gap)))
  (let* ((slot (exact-floor (/ xposition skip)))
         (offset (- xposition (* skip slot)))
         (series (exact-floor offset))
         (on-bar? (< (/ gap 2) (- offset series) (- 1 (/ gap 2)))))
    (if on-bar? (values series slot) (values #f #f))))

(define (fetch-value-at x)
  (let-values (((series slot) (xposition->histogram-slot x 2.5)))
    (and series slot (< series 2)
         (let* ((s (if (eq? series 0) series1 series2))
                (b (list-ref s slot)))
           (vector-ref b 1)))))

(define (on-hover snip event x y)
  (define ovelays
    (and x y (eq? (send event get-event-type) 'motion)
         (let ((value (fetch-value-at x)))
           (and value (<= y value)
                (list (point-label (vector x y)
                                   (format "~a minutes" value)
                                   #:anchor 'auto #:point-sym 'none))))))
  (send snip set-overlay-renderers ovelays))

(define (make-plot-snip width height)
  (define snip (plot-snip
                (list
                 (discrete-histogram series1 #:skip 2.5 #:x-min 0)
                 (discrete-histogram series2 #:skip 2.5 #:x-min 1 #:color 2 #:line-color 2))
                #:x-label "Breakfast Food" #:y-label "Cooking Time (minutes)"
                #:y-max 4
                #:width width #:height height))
  (send snip set-mouse-event-callback on-hover)
  snip)

(define toplevel (new frame% [label "Plot"] [width 500] [height 350] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)

tangent.rkt

#lang racket
(require racket/gui mrlib/snip-canvas plot)

(define ((make-tangent-renderer fn derivative) snip event x y)
  (define overlays
    (and x y (eq? (send event get-event-type) 'motion)
         (let* ((slope (derivative x))
                (intercept (- (fn x) (* slope x)))
                (tangent (lambda (x) (+ (* slope x) intercept))))
           (list (function tangent #:color "blue")
                 (points (list (vector x (fn x))))))))
  (send snip set-overlay-renderers overlays))

(define (make-plot-snip width height)
  (define snip (plot-snip (function sin)
                          #:x-min -5 #:x-max 5
                          #:y-min -1.5 #:y-max 1.5
                          #:width width #:height height))
  (send snip set-mouse-event-callback (make-tangent-renderer sin cos))
  snip)

(define toplevel (new frame% [label "Plot"] [width 500] [height 200] [border 5]))
(define canvas (new snip-canvas% [parent toplevel] [make-snip make-plot-snip]))
(send toplevel show #t)