source: trunk/gui/scripts/historesult.tcl @ 811

Last change on this file since 811 was 811, checked in by gah, 16 years ago

introduction of histogram object

File size: 49.1 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: historesult - X/Y plot in a ResultSet
3#
4#  This widget is an X/Y plot, meant to view line graphs produced
5#  as output from the run of a Rappture tool.  Use the "add" and
6#  "delete" methods to control the curves showing on the plot.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2005  Purdue Research Foundation
10#
11#  See the file "license.terms" for information on usage and
12#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13# ======================================================================
14package require Itk
15package require BLT
16
17option add *Historesult.width 3i widgetDefault
18option add *Historesult.height 3i widgetDefault
19option add *Historesult.gridColor #d9d9d9 widgetDefault
20option add *Historesult.activeColor blue widgetDefault
21option add *Historesult.dimColor gray widgetDefault
22option add *Historesult.controlBackground gray widgetDefault
23option add *Historesult.font \
24    -*-helvetica-medium-r-normal-*-12-* widgetDefault
25
26option add *Historesult.autoColors {
27    #0000ff #ff0000 #00cc00
28    #cc00cc #ff9900 #cccc00
29    #000080 #800000 #006600
30    #660066 #996600 #666600
31} widgetDefault
32
33option add *Historesult*Balloon*Entry.background white widgetDefault
34
35itcl::class Rappture::Historesult {
36    inherit itk::Widget
37
38    itk_option define -gridcolor gridColor GridColor ""
39    itk_option define -activecolor activeColor ActiveColor ""
40    itk_option define -dimcolor dimColor DimColor ""
41    itk_option define -autocolors autoColors AutoColors ""
42
43    constructor {args} { # defined below }
44    destructor { # defined below }
45
46    public method add {histogram {settings ""}}
47    public method get {}
48    public method delete {args}
49    public method scale {args}
50    public method parameters {title args} { # do nothing }
51    public method download {option args}
52
53    protected method _rebuild {}
54    protected method _resetLimits {}
55    protected method _zoom {option args}
56    protected method _hilite {state x y}
57    protected method _axis {option args}
58    protected method _getAxes {xydata}
59
60    private variable _dispatcher "" ;# dispatcher for !events
61
62    private variable _clist ""     ;# list of histogram objects
63    private variable _histo2color  ;# maps curve => plotting color
64    private variable _histo2width  ;# maps curve => line width
65    private variable _histo2dashes ;# maps curve => BLT -dashes list
66    private variable _histo2raise  ;# maps curve => raise flag 0/1
67    private variable _histo2desc   ;# maps curve => description of data
68    private variable _elem2histo   ;# maps graph element => curve
69    private variable _label2axis   ;# maps axis label => axis ID
70    private variable _limits       ;# axis limits:  x-min, x-max, etc.
71    private variable _autoColorI 0 ;# index for next "-color auto"
72
73    private variable _hilite       ;# info for element currently highlighted
74    private variable _axis         ;# info for axis manipulations
75    private variable _axisPopup    ;# info for axis being edited in popup
76    common _downloadPopup          ;# download options from popup
77}
78                                                                               
79itk::usual Historesult {
80    keep -background -foreground -cursor -font
81}
82
83# ----------------------------------------------------------------------
84# CONSTRUCTOR
85# ----------------------------------------------------------------------
86itcl::body Rappture::Historesult::constructor {args} {
87    Rappture::dispatcher _dispatcher
88    $_dispatcher register !rebuild
89    $_dispatcher dispatch $this !rebuild "[itcl::code $this _rebuild]; list"
90
91    array set _downloadPopup {
92        format csv
93    }
94
95    option add hull.width hull.height
96    pack propagate $itk_component(hull) no
97
98    itk_component add controls {
99        frame $itk_interior.cntls
100    } {
101        usual
102        rename -background -controlbackground controlBackground Background
103    }
104    pack $itk_component(controls) -side right -fill y
105
106    itk_component add reset {
107        button $itk_component(controls).reset \
108            -borderwidth 1 -padx 1 -pady 1 \
109            -bitmap [Rappture::icon reset] \
110            -command [itcl::code $this _zoom reset]
111    } {
112        usual
113        ignore -borderwidth
114        rename -highlightbackground -controlbackground controlBackground Background
115    }
116    pack $itk_component(reset) -padx 4 -pady 4
117    Rappture::Tooltip::for $itk_component(reset) "Reset the view to the default zoom level"
118
119
120    itk_component add plot {
121        blt::barchart $itk_interior.plot \
122            -highlightthickness 0 -plotpadx 0 -plotpady 0 \
123            -rightmargin 10
124    } {
125        keep -background -foreground -cursor -font
126    }
127    pack $itk_component(plot) -expand yes -fill both
128    $itk_component(plot) pen configure activeBar \
129        -pixels 3 -linewidth 2 -color black
130
131    #
132    # Add bindings so you can mouse over points to see values:
133    #
134    bind $itk_component(plot) <Motion> \
135        [itcl::code $this _hilite at %x %y]
136    bind $itk_component(plot) <Leave> \
137        [itcl::code $this _hilite off %x %y]
138
139    #
140    # Add support for editing axes:
141    #
142    Rappture::Balloon $itk_component(hull).axes -title "Axis Options"
143    set inner [$itk_component(hull).axes component inner]
144
145    label $inner.labell -text "Label:"
146    entry $inner.label -width 15 -highlightbackground $itk_option(-background)
147    grid $inner.labell -row 1 -column 0 -sticky e
148    grid $inner.label -row 1 -column 1 -sticky ew -pady 4
149
150    label $inner.minl -text "Minimum:"
151    entry $inner.min -width 15 -highlightbackground $itk_option(-background)
152    grid $inner.minl -row 2 -column 0 -sticky e
153    grid $inner.min -row 2 -column 1 -sticky ew -pady 4
154
155    label $inner.maxl -text "Maximum:"
156    entry $inner.max -width 15 -highlightbackground $itk_option(-background)
157    grid $inner.maxl -row 3 -column 0 -sticky e
158    grid $inner.max -row 3 -column 1 -sticky ew -pady 4
159
160    label $inner.formatl -text "Format:"
161    Rappture::Combobox $inner.format -width 15 -editable no
162    $inner.format choices insert end \
163        "%.3g"  "Auto"         \
164        "%.0f"  "X"          \
165        "%.1f"  "X.X"          \
166        "%.2f"  "X.XX"         \
167        "%.3f"  "X.XXX"        \
168        "%.6f"  "X.XXXXXX"     \
169        "%.1e"  "X.Xe+XX"      \
170        "%.2e"  "X.XXe+XX"     \
171        "%.3e"  "X.XXXe+XX"    \
172        "%.6e"  "X.XXXXXXe+XX"
173    grid $inner.formatl -row 4 -column 0 -sticky e
174    grid $inner.format -row 4 -column 1 -sticky ew -pady 4
175
176    label $inner.scalel -text "Scale:"
177    frame $inner.scales
178    radiobutton $inner.scales.linear -text "Linear" \
179        -variable [itcl::scope _axisPopup(scale)] -value "linear"
180    pack $inner.scales.linear -side left
181    radiobutton $inner.scales.log -text "Logarithmic" \
182        -variable [itcl::scope _axisPopup(scale)] -value "log"
183    pack $inner.scales.log -side left
184    grid $inner.scalel -row 5 -column 0 -sticky e
185    grid $inner.scales -row 5 -column 1 -sticky ew -pady 4
186
187    foreach axis {x y} {
188        set _axisPopup(format-$axis) "%.3g"
189    }
190    _axis scale x linear
191    _axis scale y linear
192
193    # quick-and-dirty zoom functionality, for now...
194    Blt_ZoomStack $itk_component(plot)
195    $itk_component(plot) legend configure -hide yes
196
197    eval itk_initialize $args
198
199    set _hilite(elem) ""
200}
201
202# ----------------------------------------------------------------------
203# DESTRUCTOR
204# ----------------------------------------------------------------------
205itcl::body Rappture::Historesult::destructor {} {
206}
207
208# ----------------------------------------------------------------------
209# USAGE: add <curve> ?<settings>?
210#
211# Clients use this to add a curve to the plot.  The optional <settings>
212# are used to configure the plot.  Allowed settings are -color,
213# -brightness, -width, -linestyle and -raise.
214# ----------------------------------------------------------------------
215itcl::body Rappture::Historesult::add {curve {settings ""}} {
216    array set params {
217        -color auto
218        -brightness 0
219        -width 1
220        -type "line"
221        -raise 0
222        -linestyle solid
223        -description ""
224        -param ""
225    }
226    foreach {opt val} $settings {
227        if {![info exists params($opt)]} {
228            error "bad setting \"$opt\": should be [join [lsort [array names params]] {, }]"
229        }
230        set params($opt) $val
231    }
232
233    # if type is set to "scatter", then override the width
234    if {"scatter" == $params(-type)} {
235        set params(-width) 0
236    }
237
238    # if the color is "auto", then select a color from -autocolors
239    if {$params(-color) == "auto" || $params(-color) == "autoreset"} {
240        if {$params(-color) == "autoreset"} {
241            set _autoColorI 0
242        }
243        set color [lindex $itk_option(-autocolors) $_autoColorI]
244        if {"" == $color} { set color black }
245        set params(-color) $color
246
247        # set up for next auto color
248        if {[incr _autoColorI] >= [llength $itk_option(-autocolors)]} {
249            set _autoColorI 0
250        }
251    }
252
253    # convert -linestyle to BLT -dashes
254    switch -- $params(-linestyle) {
255        dashed { set params(-linestyle) {4 4} }
256        dotted { set params(-linestyle) {2 4} }
257        default { set params(-linestyle) {} }
258    }
259
260    # if -brightness is set, then update the color
261    if {$params(-brightness) != 0} {
262        set params(-color) [Rappture::color::brightness \
263            $params(-color) $params(-brightness)]
264
265        set bg [$itk_component(plot) cget -plotbackground]
266        foreach {h s v} [Rappture::color::RGBtoHSV $bg] break
267        if {$v > 0.5} {
268            set params(-color) [Rappture::color::brightness_max \
269                $params(-color) 0.8]
270        } else {
271            set params(-color) [Rappture::color::brightness_min \
272                $params(-color) 0.2]
273        }
274    }
275
276    set pos [lsearch -exact $curve $_clist]
277    if {$pos < 0} {
278        lappend _clist $curve
279        set _curve2color($curve) $params(-color)
280        set _curve2width($curve) $params(-width)
281        set _curve2dashes($curve) $params(-linestyle)
282        set _curve2raise($curve) $params(-raise)
283        set _curve2desc($curve) $params(-description)
284
285        $_dispatcher event -idle !rebuild
286    }
287}
288
289# ----------------------------------------------------------------------
290# USAGE: get
291#
292# Clients use this to query the list of objects being plotted, in
293# order from bottom to top of this result.
294# ----------------------------------------------------------------------
295itcl::body Rappture::Historesult::get {} {
296    # put the dataobj list in order according to -raise options
297    set clist $_clist
298    foreach obj $clist {
299        if {[info exists _curve2raise($obj)] && $_curve2raise($obj)} {
300            set i [lsearch -exact $clist $obj]
301            if {$i >= 0} {
302                set clist [lreplace $clist $i $i]
303                lappend clist $obj
304            }
305        }
306    }
307    return $clist
308}
309
310# ----------------------------------------------------------------------
311# USAGE: delete ?<curve1> <curve2> ...?
312#
313# Clients use this to delete a curve from the plot.  If no curves
314# are specified, then all curves are deleted.
315# ----------------------------------------------------------------------
316itcl::body Rappture::Historesult::delete {args} {
317    if {[llength $args] == 0} {
318        set args $_clist
319    }
320
321    # delete all specified curves
322    set changed 0
323    foreach curve $args {
324        set pos [lsearch -exact $_clist $curve]
325        if {$pos >= 0} {
326            set _clist [lreplace $_clist $pos $pos]
327            catch {unset _curve2color($curve)}
328            catch {unset _curve2width($curve)}
329            catch {unset _curve2dashes($curve)}
330            catch {unset _curve2raise($curve)}
331            foreach elem [array names _elem2curve] {
332                if {$_elem2curve($elem) == $curve} {
333                    unset _elem2curve($elem)
334                }
335            }
336            set changed 1
337        }
338    }
339
340    # if anything changed, then rebuild the plot
341    if {$changed} {
342        $_dispatcher event -idle !rebuild
343    }
344
345    # nothing left? then start over with auto colors
346    if {[llength $_clist] == 0} {
347        set _autoColorI 0
348    }
349}
350
351# ----------------------------------------------------------------------
352# USAGE: scale ?<curve1> <curve2> ...?
353#
354# Sets the default limits for the overall plot according to the
355# limits of the data for all of the given <curve> objects.  This
356# accounts for all curves--even those not showing on the screen.
357# Because of this, the limits are appropriate for all curves as
358# the user scans through data in the ResultSet viewer.
359# ----------------------------------------------------------------------
360itcl::body Rappture::Historesult::scale {args} {
361    set allx [$itk_component(plot) x2axis use]
362    lappend allx x  ;# fix main x-axis too
363    foreach axis $allx {
364        _axis scale $axis linear
365    }
366
367    set ally [$itk_component(plot) y2axis use]
368    lappend ally y  ;# fix main y-axis too
369    foreach axis $ally {
370        _axis scale $axis linear
371    }
372
373    catch {unset _limits}
374    foreach xydata $args {
375        # find the axes for this curve (e.g., {x y2})
376        foreach {map(x) map(y)} [_getAxes $xydata] break
377
378        foreach axis {x y} {
379            # get defaults for both linear and log scales
380            foreach type {lin log} {
381                # store results -- ex: _limits(x2log-min)
382                set id $map($axis)$type
383                foreach {min max} [$xydata limits $axis$type] break
384                if {"" != $min && "" != $max} {
385                    if {![info exists _limits($id-min)]} {
386                        set _limits($id-min) $min
387                        set _limits($id-max) $max
388                    } else {
389                        if {$min < $_limits($id-min)} {
390                            set _limits($id-min) $min
391                        }
392                        if {$max > $_limits($id-max)} {
393                            set _limits($id-max) $max
394                        }
395                    }
396                }
397            }
398
399            if {[$xydata hints ${axis}scale] == "log"} {
400                _axis scale $map($axis) log
401            }
402        }
403    }
404    _resetLimits
405}
406
407# ----------------------------------------------------------------------
408# USAGE: download coming
409# USAGE: download controls <downloadCommand>
410# USAGE: download now
411#
412# Clients use this method to create a downloadable representation
413# of the plot.  Returns a list of the form {ext string}, where
414# "ext" is the file extension (indicating the type of data) and
415# "string" is the data itself.
416# ----------------------------------------------------------------------
417itcl::body Rappture::Historesult::download {option args} {
418    switch $option {
419        coming {
420            # nothing to do
421        }
422        controls {
423            set popup .historesultdownload
424            if {![winfo exists .historesultdownload]} {
425                # if we haven't created the popup yet, do it now
426                Rappture::Balloon $popup -title "Download as..."
427                set inner [$popup component inner]
428                label $inner.summary -text "" -anchor w
429                pack $inner.summary -side top
430                radiobutton $inner.csv -text "Data as Comma-Separated Values" \
431                    -variable Rappture::Historesult::_downloadPopup(format) \
432                    -value csv
433                pack $inner.csv -anchor w
434                radiobutton $inner.pdf -text "Image as PDF/PostScript" \
435                    -variable Rappture::Historesult::_downloadPopup(format) \
436                    -value pdf
437                pack $inner.pdf -anchor w
438                button $inner.go -text "Download Now" \
439                    -command [lindex $args 0]
440                pack $inner.go -pady 4
441            } else {
442                set inner [$popup component inner]
443            }
444            set num [llength [get]]
445            set num [expr {($num == 1) ? "1 result" : "$num results"}]
446            $inner.summary configure -text "Download $num in the following format:"
447            update idletasks ;# fix initial sizes
448            return $popup
449        }
450        now {
451            set popup .historesultdownload
452            if {[winfo exists .historesultdownload]} {
453                $popup deactivate
454            }
455            switch -- $_downloadPopup(format) {
456              csv {
457                # reverse the objects so the selected data appears on top
458                set dlist ""
459                foreach dataobj [get] {
460                    set dlist [linsert $dlist 0 $dataobj]
461                }
462
463                # generate the comma-separated value data for these objects
464                set csvdata ""
465                foreach dataobj $dlist {
466                    append csvdata "[string repeat - 60]\n"
467                    append csvdata " [$dataobj hints label]\n"
468                    if {[info exists _curve2desc($dataobj)]
469                          && [llength [split $_curve2desc($dataobj) \n]] > 1} {
470                        set indent "for:"
471                        foreach line [split $_curve2desc($dataobj) \n] {
472                            append csvdata " $indent $line\n"
473                            set indent "    "
474                        }
475                    }
476                    append csvdata "[string repeat - 60]\n"
477
478                    append csvdata "[$dataobj hints xlabel], [$dataobj hints ylabel]\n"
479                    set first 1
480                    foreach comp [$dataobj components] {
481                        if {!$first} {
482                            # blank line between components
483                            append csvdata "\n"
484                        }
485                        set xv [$dataobj mesh $comp]
486                        set yv [$dataobj values $comp]
487                        foreach x [$xv range 0 end] y [$yv range 0 end] {
488                            append csvdata [format "%20.15g, %20.15g\n" $x $y]
489                        }
490                        set first 0
491                    }
492                    append csvdata "\n"
493                }
494                return [list .txt $csvdata]
495              }
496              pdf {
497                set psdata [$itk_component(plot) postscript output -decorations no -maxpect 1]
498
499                set cmds {
500                    set fout "histogram[pid].pdf"
501                    exec ps2pdf - $fout << $psdata
502
503                    set fid [open $fout r]
504                    fconfigure $fid -translation binary -encoding binary
505                    set pdfdata [read $fid]
506                    close $fid
507
508                    file delete -force $fout
509                }
510                if {[catch $cmds result] == 0} {
511                    return [list .pdf $pdfdata]
512                }
513                return [list .ps $psdata]
514              }
515            }
516        }
517        default {
518            error "bad option \"$option\": should be coming, controls, now"
519        }
520    }
521}
522
523# ----------------------------------------------------------------------
524# USAGE: _rebuild
525#
526# Called automatically whenever something changes that affects the
527# data in the widget.  Clears any existing data and rebuilds the
528# widget to display new data.
529# ----------------------------------------------------------------------
530itcl::body Rappture::Historesult::_rebuild {} {
531    set g $itk_component(plot)
532
533    # first clear out the widget
534    eval $g element delete [$g element names]
535    foreach axis [$g axis names] {
536        $g axis configure $axis -hide yes
537    }
538    catch {unset _label2axis}
539
540    #
541    # Scan through all objects and create a list of all axes.
542    # The first x-axis gets mapped to "x".  The second, to "x2".
543    # Beyond that, we must create new axes "x3", "x4", etc.
544    # We do the same for y.
545    #
546    set anum(x) 0
547    set anum(y) 0
548    foreach xydata [get] {
549        foreach ax {x y} {
550            set label [$xydata hints ${ax}label]
551            if {"" != $label} {
552                if {![info exists _label2axis($ax-$label)]} {
553                    switch [incr anum($ax)] {
554                        1 { set axis $ax }
555                        2 { set axis ${ax}2 }
556                        default {
557                            set axis $ax$anum($ax)
558                            catch {$g axis create $axis}
559                        }
560                    }
561                    $g axis configure $axis -title $label -hide no
562                    set _label2axis($ax-$label) $axis
563
564                    # if this axis has a description, add it as a tooltip
565                    set desc [string trim [$xydata hints ${ax}desc]]
566                    Rappture::Tooltip::text $g-$axis $desc
567                }
568            }
569        }
570    }
571
572    #
573    # All of the extra axes get mapped to the x2/y2 (top/right)
574    # position.
575    #
576    set all ""
577    foreach ax {x y} {
578        lappend all $ax
579
580        set extra ""
581        for {set i 2} {$i <= $anum($ax)} {incr i} {
582            lappend extra ${ax}$i
583        }
584        eval lappend all $extra
585        $g ${ax}2axis use $extra
586        if {$ax == "y"} {
587            $g configure -rightmargin [expr {($extra == "") ? 10 : 0}]
588        }
589    }
590
591    foreach axis $all {
592        set _axisPopup(format-$axis) "%.3g"
593
594        $g axis bind $axis <Enter> \
595            [itcl::code $this _axis hilite $axis on]
596        $g axis bind $axis <Leave> \
597            [itcl::code $this _axis hilite $axis off]
598        $g axis bind $axis <ButtonPress> \
599            [itcl::code $this _axis click $axis %x %y]
600        $g axis bind $axis <B1-Motion> \
601            [itcl::code $this _axis drag $axis %x %y]
602        $g axis bind $axis <ButtonRelease> \
603            [itcl::code $this _axis release $axis %x %y]
604        $g axis bind $axis <KeyPress> \
605            [list ::Rappture::Tooltip::tooltip cancel]
606    }
607
608    #
609    # Plot all of the curves.
610    #
611    set count 0
612    foreach xydata $_clist {
613        set label [$xydata hints label]
614        foreach {mapx mapy} [_getAxes $xydata] break
615
616        foreach comp [$xydata components] {
617            set xv [$xydata mesh $comp]
618            set yv [$xydata values $comp]
619
620            if {[info exists _curve2color($xydata)]} {
621                set color $_curve2color($xydata)
622            } else {
623                set color [$xydata hints color]
624                if {"" == $color} {
625                    set color black
626                }
627            }
628
629            if {[info exists _curve2width($xydata)]} {
630                set lwidth $_curve2width($xydata)
631            } else {
632                set lwidth 2
633            }
634
635            if {[info exists _curve2dashes($xydata)]} {
636                set dashes $_curve2dashes($xydata)
637            } else {
638                set dashes ""
639            }
640
641            if {([$xv length] <= 1) || ($lwidth == 0)} {
642                set sym square
643                set pixels 2
644            } else {
645                set sym ""
646                set pixels 6
647            }
648
649            set elem "elem[incr count]"
650            set _elem2curve($elem) $xydata
651
652            $g element create $elem -x $xv -y $yv \
653                -symbol $sym -pixels $pixels -linewidth $lwidth -label $label \
654                -color $color -dashes $dashes \
655                -mapx $mapx -mapy $mapy
656        }
657    }
658}
659
660# ----------------------------------------------------------------------
661# USAGE: _resetLimits
662#
663# Used internally to apply automatic limits to the axes for the
664# current plot.
665# ----------------------------------------------------------------------
666itcl::body Rappture::Historesult::_resetLimits {} {
667    set g $itk_component(plot)
668
669    #
670    # HACK ALERT!
671    # Use this code to fix up the y-axis limits for the BLT graph.
672    # The auto-limits don't always work well.  We want them to be
673    # set to a "nice" number slightly above or below the min/max
674    # limits.
675    #
676    foreach axis [$g axis names] {
677        if {[info exists _limits(${axis}lin-min)]} {
678            set log [$g axis cget $axis -logscale]
679            if {$log} {
680                set min $_limits(${axis}log-min)
681                if {$min == 0} { set min 1 }
682                set max $_limits(${axis}log-max)
683                if {$max == 0} { set max 1 }
684
685                if {$min == $max} {
686                    set logmin [expr {floor(log10(abs(0.9*$min)))}]
687                    set logmax [expr {ceil(log10(abs(1.1*$max)))}]
688                } else {
689                    set logmin [expr {floor(log10(abs($min)))}]
690                    set logmax [expr {ceil(log10(abs($max)))}]
691                    if {[string match y* $axis]} {
692                        # add a little padding
693                        set delta [expr {$logmax-$logmin}]
694                        if {$delta == 0} { set delta 1 }
695                        set logmin [expr {$logmin-0.05*$delta}]
696                        set logmax [expr {$logmax+0.05*$delta}]
697                    }
698                }
699                if {$logmin < -300} {
700                    set min 1e-300
701                } elseif {$logmin > 300} {
702                    set min 1e+300
703                } else {
704                    set min [expr {pow(10.0,$logmin)}]
705                }
706
707                if {$logmax < -300} {
708                    set max 1e-300
709                } elseif {$logmax > 300} {
710                    set max 1e+300
711                } else {
712                    set max [expr {pow(10.0,$logmax)}]
713                }
714            } else {
715                set min $_limits(${axis}lin-min)
716                set max $_limits(${axis}lin-max)
717
718                if {[string match y* $axis]} {
719                    # add a little padding
720                    set delta [expr {$max-$min}]
721                    set min [expr {$min-0.05*$delta}]
722                    set max [expr {$max+0.05*$delta}]
723                }
724            }
725            if {$min < $max} {
726                $g axis configure $axis -min $min -max $max
727            } else {
728                $g axis configure $axis -min "" -max ""
729            }
730        } else {
731            $g axis configure $axis -min "" -max ""
732        }
733    }
734}
735
736# ----------------------------------------------------------------------
737# USAGE: _zoom reset
738#
739# Called automatically when the user clicks on one of the zoom
740# controls for this widget.  Changes the zoom for the current view.
741# ----------------------------------------------------------------------
742itcl::body Rappture::Historesult::_zoom {option args} {
743    switch -- $option {
744        reset {
745            _resetLimits
746        }
747    }
748}
749
750# ----------------------------------------------------------------------
751# USAGE: _hilite <state> <x> <y>
752#
753# Called automatically when the user brushes one of the elements
754# on the plot.  Causes the element to highlight and a tooltip to
755# pop up with element info.
756# ----------------------------------------------------------------------
757itcl::body Rappture::Historesult::_hilite {state x y} {
758    set g $itk_component(plot)
759    set elem ""
760    if {$state == "at"} {
761        if {[$g element closest $x $y info -interpolate yes]} {
762            # for dealing with xy line plots
763            set elem $info(name)
764            foreach {mapx mapy} [_getAxes $_elem2curve($elem)] break
765
766            # search again for an exact point -- this time don't interpolate
767            set tip ""
768            if {[$g element closest $x $y info -interpolate no]
769                  && $info(name) == $elem} {
770                set x [$g axis transform $mapx $info(x)]
771                set y [$g axis transform $mapy $info(y)]
772
773                if {[info exists _elem2curve($elem)]} {
774                    set curve $_elem2curve($elem)
775                    set tip [$curve hints tooltip]
776                    if {[info exists info(y)]} {
777                        set val [_axis format y dummy $info(y)]
778                        set units [$curve hints yunits]
779                        append tip "\n$val$units"
780
781                        if {[info exists info(x)]} {
782                            set val [_axis format x dummy $info(x)]
783                            set units [$curve hints xunits]
784                            append tip " @ $val$units"
785                        }
786                    }
787                    set tip [string trim $tip]
788                }
789            }
790            set state 1
791        } elseif {[$g element closest $x $y info -interpolate no]} {
792            # for dealing with xy scatter plot
793            set elem $info(name)
794            foreach {mapx mapy} [_getAxes $_elem2curve($elem)] break
795
796            # search again for an exact point -- this time don't interpolate
797            set tip ""
798            if {$info(name) == $elem} {
799                set x [$g axis transform $mapx $info(x)]
800                set y [$g axis transform $mapy $info(y)]
801
802                if {[info exists _elem2curve($elem)]} {
803                    set curve $_elem2curve($elem)
804                    set tip [$curve hints tooltip]
805                    if {[info exists info(y)]} {
806                        set val [_axis format y dummy $info(y)]
807                        set units [$curve hints yunits]
808                        append tip "\n$val$units"
809
810                        if {[info exists info(x)]} {
811                            set val [_axis format x dummy $info(x)]
812                            set units [$curve hints xunits]
813                            append tip " @ $val$units"
814                        }
815                    }
816                    set tip [string trim $tip]
817                }
818            }
819            set state 1
820        } else {
821            set state 0
822        }
823    }
824
825    if {$state} {
826        #
827        # Highlight ON:
828        # - activate trace
829        # - multiple axes? dim other axes
830        # - pop up tooltip about data
831        #
832        if {$_hilite(elem) != "" && $_hilite(elem) != $elem} {
833            $g element deactivate $_hilite(elem)
834            $g crosshairs configure -hide yes
835            Rappture::Tooltip::tooltip cancel
836        }
837        $g element activate $elem
838        set _hilite(elem) $elem
839
840        set dlist [$g element show]
841        set i [lsearch -exact $dlist $elem]
842        if {$i >= 0} {
843            set dlist [lreplace $dlist $i $i]
844            lappend dlist $elem
845            $g element show $dlist
846        }
847
848        foreach {mapx mapy} [_getAxes $_elem2curve($elem)] break
849
850        set allx [$g x2axis use]
851        if {[llength $allx] > 0} {
852            lappend allx x  ;# fix main x-axis too
853            foreach axis $allx {
854                if {$axis == $mapx} {
855                    $g axis configure $axis -color $itk_option(-foreground) \
856                        -titlecolor $itk_option(-foreground)
857                } else {
858                    $g axis configure $axis -color $itk_option(-dimcolor) \
859                        -titlecolor $itk_option(-dimcolor)
860                }
861            }
862        }
863        set ally [$g y2axis use]
864        if {[llength $ally] > 0} {
865            lappend ally y  ;# fix main y-axis too
866            foreach axis $ally {
867                if {$axis == $mapy} {
868                    $g axis configure $axis -color $itk_option(-foreground) \
869                        -titlecolor $itk_option(-foreground)
870                } else {
871                    $g axis configure $axis -color $itk_option(-dimcolor) \
872                        -titlecolor $itk_option(-dimcolor)
873                }
874            }
875        }
876
877        if {"" != $tip} {
878            $g crosshairs configure -hide no -position @$x,$y
879
880            if {$x > 0.5*[winfo width $g]} {
881                if {$x < 4} {
882                    set tipx "-0"
883                } else {
884                    set tipx "-[expr {$x-4}]"  ;# move tooltip to the left
885                }
886            } else {
887                if {$x < -4} {
888                    set tipx "+0"
889                } else {
890                    set tipx "+[expr {$x+4}]"  ;# move tooltip to the right
891                }
892            }
893            if {$y > 0.5*[winfo height $g]} {
894                if {$y < 4} {
895                    set tipy "-0"
896                } else {
897                    set tipy "-[expr {$y-4}]"  ;# move tooltip to the top
898                }
899            } else {
900                if {$y < -4} {
901                    set tipy "+0"
902                } else {
903                    set tipy "+[expr {$y+4}]"  ;# move tooltip to the bottom
904                }
905            }
906            Rappture::Tooltip::text $g $tip
907            Rappture::Tooltip::tooltip show $g $tipx,$tipy
908        }
909    } else {
910        #
911        # Highlight OFF:
912        # - deactivate (color back to normal)
913        # - put all axes back to normal color
914        # - take down tooltip
915        #
916        if {"" != $_hilite(elem)} {
917            $g element deactivate $_hilite(elem)
918
919            set allx [$g x2axis use]
920            if {[llength $allx] > 0} {
921                lappend allx x  ;# fix main x-axis too
922                foreach axis $allx {
923                    $g axis configure $axis -color $itk_option(-foreground) \
924                        -titlecolor $itk_option(-foreground)
925                }
926            }
927
928            set ally [$g y2axis use]
929            if {[llength $ally] > 0} {
930                lappend ally y  ;# fix main y-axis too
931                foreach axis $ally {
932                    $g axis configure $axis -color $itk_option(-foreground) \
933                        -titlecolor $itk_option(-foreground)
934                }
935            }
936        }
937
938        $g crosshairs configure -hide yes
939
940        # only cancel in plotting area or we'll mess up axes
941        if {[$g inside $x $y]} {
942            Rappture::Tooltip::tooltip cancel
943        }
944
945        # there is no currently highlighted element
946        set _hilite(elem) ""
947    }
948}
949
950# ----------------------------------------------------------------------
951# USAGE: _axis hilite <axis> <state>
952#
953# USAGE: _axis click <axis> <x> <y>
954# USAGE: _axis drag <axis> <x> <y>
955# USAGE: _axis release <axis> <x> <y>
956#
957# USAGE: _axis edit <axis>
958# USAGE: _axis changed <axis> <what>
959# USAGE: _axis format <axis> <widget> <value>
960# USAGE: _axis scale <axis> linear|log
961#
962# Used internally to handle editing of the x/y axes.  The hilite
963# operation causes the axis to light up.  The edit operation pops
964# up a panel with editing options.  The changed operation applies
965# changes from the panel.
966# ----------------------------------------------------------------------
967itcl::body Rappture::Historesult::_axis {option args} {
968    set inner [$itk_component(hull).axes component inner]
969
970    switch -- $option {
971        hilite {
972            if {[llength $args] != 2} {
973                error "wrong # args: should be \"_axis hilite axis state\""
974            }
975            set g $itk_component(plot)
976            set axis [lindex $args 0]
977            set state [lindex $args 1]
978
979            if {$state} {
980                $g axis configure $axis \
981                    -color $itk_option(-activecolor) \
982                    -titlecolor $itk_option(-activecolor)
983
984                set x [expr {[winfo pointerx $g]+4}]
985                set y [expr {[winfo pointery $g]+4}]
986                Rappture::Tooltip::tooltip pending $g-$axis @$x,$y
987            } else {
988                $g axis configure $axis \
989                    -color $itk_option(-foreground) \
990                    -titlecolor $itk_option(-foreground)
991                Rappture::Tooltip::tooltip cancel
992            }
993        }
994        click {
995            if {[llength $args] != 3} {
996                error "wrong # args: should be \"_axis click axis x y\""
997            }
998            set axis [lindex $args 0]
999            set x [lindex $args 1]
1000            set y [lindex $args 2]
1001            set g $itk_component(plot)
1002
1003            set _axis(moved) 0
1004            set _axis(click-x) $x
1005            set _axis(click-y) $y
1006            foreach {min max} [$g axis limits $axis] break
1007            set _axis(min0) $min
1008            set _axis(max0) $max
1009            Rappture::Tooltip::tooltip cancel
1010        }
1011        drag {
1012            if {[llength $args] != 3} {
1013                error "wrong # args: should be \"_axis drag axis x y\""
1014            }
1015            if {![info exists _axis(moved)]} {
1016                return  ;# must have skipped click event -- ignore
1017            }
1018            set axis [lindex $args 0]
1019            set x [lindex $args 1]
1020            set y [lindex $args 2]
1021            set g $itk_component(plot)
1022
1023            if {[info exists _axis(click-x)] && [info exists _axis(click-y)]} {
1024                foreach {x0 y0 pw ph} [$g extents plotarea] break
1025                switch -glob $axis {
1026                  x* {
1027                    set pix $x
1028                    set pix0 $_axis(click-x)
1029                    set pixmin $x0
1030                    set pixmax [expr {$x0+$pw}]
1031                  }
1032                  y* {
1033                    set pix $y
1034                    set pix0 $_axis(click-y)
1035                    set pixmin [expr {$y0+$ph}]
1036                    set pixmax $y0
1037                  }
1038                }
1039                set log [$g axis cget $axis -logscale]
1040                set min $_axis(min0)
1041                set max $_axis(max0)
1042                set dpix [expr {abs($pix-$pix0)}]
1043                set v0 [$g axis invtransform $axis $pixmin]
1044                set v1 [$g axis invtransform $axis [expr {$pixmin+$dpix}]]
1045                if {$log} {
1046                    set v0 [expr {log10($v0)}]
1047                    set v1 [expr {log10($v1)}]
1048                    set min [expr {log10($min)}]
1049                    set max [expr {log10($max)}]
1050                }
1051
1052                if {$pix > $pix0} {
1053                    set delta [expr {$v1-$v0}]
1054                } else {
1055                    set delta [expr {$v0-$v1}]
1056                }
1057                set min [expr {$min-$delta}]
1058                set max [expr {$max-$delta}]
1059                if {$log} {
1060                    set min [expr {pow(10.0,$min)}]
1061                    set max [expr {pow(10.0,$max)}]
1062                }
1063                $g axis configure $axis -min $min -max $max
1064
1065                # move axis, don't edit on release
1066                set _axis(move) 1
1067            }
1068        }
1069        release {
1070            if {[llength $args] != 3} {
1071                error "wrong # args: should be \"_axis release axis x y\""
1072            }
1073            if {![info exists _axis(moved)]} {
1074                return  ;# must have skipped click event -- ignore
1075            }
1076            set axis [lindex $args 0]
1077            set x [lindex $args 1]
1078            set y [lindex $args 2]
1079
1080            if {!$_axis(moved)} {
1081                # small movement? then treat as click -- pop up axis editor
1082                set dx [expr {abs($x-$_axis(click-x))}]
1083                set dy [expr {abs($y-$_axis(click-y))}]
1084                if {$dx < 2 && $dy < 2} {
1085                    _axis edit $axis
1086                }
1087            } else {
1088                # one last movement
1089                _axis drag $axis $x $y
1090            }
1091            catch {unset _axis}
1092        }
1093        edit {
1094            if {[llength $args] != 1} {
1095                error "wrong # args: should be \"_axis edit axis\""
1096            }
1097            set axis [lindex $args 0]
1098            set _axisPopup(current) $axis
1099
1100            # apply last value when deactivating
1101            $itk_component(hull).axes configure -deactivatecommand \
1102                [itcl::code $this _axis changed $axis focus]
1103
1104            # fix axis label controls...
1105            set label [$itk_component(plot) axis cget $axis -title]
1106            $inner.label delete 0 end
1107            $inner.label insert end $label
1108            bind $inner.label <KeyPress-Return> \
1109                [itcl::code $this _axis changed $axis label]
1110            bind $inner.label <FocusOut> \
1111                [itcl::code $this _axis changed $axis label]
1112
1113            # fix min/max controls...
1114            foreach {min max} [$itk_component(plot) axis limits $axis] break
1115            $inner.min delete 0 end
1116            $inner.min insert end $min
1117            bind $inner.min <KeyPress-Return> \
1118                [itcl::code $this _axis changed $axis min]
1119            bind $inner.min <FocusOut> \
1120                [itcl::code $this _axis changed $axis min]
1121
1122            $inner.max delete 0 end
1123            $inner.max insert end $max
1124            bind $inner.max <KeyPress-Return> \
1125                [itcl::code $this _axis changed $axis max]
1126            bind $inner.max <FocusOut> \
1127                [itcl::code $this _axis changed $axis max]
1128
1129            # fix format control...
1130            set fmts [$inner.format choices get -value]
1131            set i [lsearch -exact $fmts $_axisPopup(format-$axis)]
1132            if {$i < 0} { set i 0 }  ;# use Auto choice
1133            $inner.format value [$inner.format choices get -label $i]
1134
1135            bind $inner.format <<Value>> \
1136                [itcl::code $this _axis changed $axis format]
1137
1138            # fix scale control...
1139            if {[$itk_component(plot) axis cget $axis -logscale]} {
1140                set _axisPopup(scale) "log"
1141                $inner.format configure -state disabled
1142            } else {
1143                set _axisPopup(scale) "linear"
1144                $inner.format configure -state normal
1145            }
1146            $inner.scales.linear configure \
1147                -command [itcl::code $this _axis changed $axis scale]
1148            $inner.scales.log configure \
1149                -command [itcl::code $this _axis changed $axis scale]
1150
1151            #
1152            # Figure out where the window should pop up.
1153            #
1154            set x [winfo rootx $itk_component(plot)]
1155            set y [winfo rooty $itk_component(plot)]
1156            set w [winfo width $itk_component(plot)]
1157            set h [winfo height $itk_component(plot)]
1158            foreach {x0 y0 pw ph} [$itk_component(plot) extents plotarea] break
1159            switch -glob -- $axis {
1160                x {
1161                    set x [expr {round($x + $x0+0.5*$pw)}]
1162                    set y [expr {round($y + $y0+$ph + 0.5*($h-$y0-$ph))}]
1163                    set dir "above"
1164                }
1165                x* {
1166                    set x [expr {round($x + $x0+0.5*$pw)}]
1167                    set dir "below"
1168                    set allx [$itk_component(plot) x2axis use]
1169                    set max [llength $allx]
1170                    set i [lsearch -exact $allx $axis]
1171                    set y [expr {round($y + ($i+0.5)*$y0/double($max))}]
1172                }
1173                y {
1174                    set x [expr {round($x + 0.5*$x0)}]
1175                    set y [expr {round($y + $y0+0.5*$ph)}]
1176                    set dir "right"
1177                }
1178                y* {
1179                    set y [expr {round($y + $y0+0.5*$ph)}]
1180                    set dir "left"
1181                    set ally [$itk_component(plot) y2axis use]
1182                    set max [llength $ally]
1183                    set i [lsearch -exact $ally $axis]
1184                    set y [expr {round($y + ($i+0.5)*$y0/double($max))}]
1185                    set x [expr {round($x+$x0+$pw + ($i+0.5)*($w-$x0-$pw)/double($max))}]
1186                }
1187            }
1188            $itk_component(hull).axes activate @$x,$y $dir
1189        }
1190        changed {
1191            if {[llength $args] != 2} {
1192                error "wrong # args: should be \"_axis changed axis what\""
1193            }
1194            set axis [lindex $args 0]
1195            set what [lindex $args 1]
1196            if {$what == "focus"} {
1197                set what [focus]
1198                if {[winfo exists $what]} {
1199                    set what [winfo name $what]
1200                }
1201            }
1202
1203            switch -- $what {
1204                label {
1205                    set val [$inner.label get]
1206                    $itk_component(plot) axis configure $axis -title $val
1207                }
1208                min {
1209                    set val [$inner.min get]
1210                    if {![string is double -strict $val]} {
1211                        Rappture::Tooltip::cue $inner.min "Must be a number"
1212                        bell
1213                        return
1214                    }
1215
1216                    set max [lindex [$itk_component(plot) axis limits $axis] 1]
1217                    if {$val >= $max} {
1218                        Rappture::Tooltip::cue $inner.min "Must be <= max ($max)"
1219                        bell
1220                        return
1221                    }
1222                    catch {
1223                        # can fail in log mode
1224                        $itk_component(plot) axis configure $axis -min $val
1225                    }
1226                    foreach {min max} [$itk_component(plot) axis limits $axis] break
1227                    $inner.min delete 0 end
1228                    $inner.min insert end $min
1229                }
1230                max {
1231                    set val [$inner.max get]
1232                    if {![string is double -strict $val]} {
1233                        Rappture::Tooltip::cue $inner.max "Should be a number"
1234                        bell
1235                        return
1236                    }
1237
1238                    set min [lindex [$itk_component(plot) axis limits $axis] 0]
1239                    if {$val <= $min} {
1240                        Rappture::Tooltip::cue $inner.max "Must be >= min ($min)"
1241                        bell
1242                        return
1243                    }
1244                    catch {
1245                        # can fail in log mode
1246                        $itk_component(plot) axis configure $axis -max $val
1247                    }
1248                    foreach {min max} [$itk_component(plot) axis limits $axis] break
1249                    $inner.max delete 0 end
1250                    $inner.max insert end $max
1251                }
1252                format {
1253                    set fmt [$inner.format translate [$inner.format value]]
1254                    set _axisPopup(format-$axis) $fmt
1255
1256                    # force a refresh
1257                    $itk_component(plot) axis configure $axis -min \
1258                        [$itk_component(plot) axis cget $axis -min]
1259                }
1260                scale {
1261                    _axis scale $axis $_axisPopup(scale)
1262
1263                    if {$_axisPopup(scale) == "log"} {
1264                        $inner.format configure -state disabled
1265                    } else {
1266                        $inner.format configure -state normal
1267                    }
1268
1269                    foreach {min max} [$itk_component(plot) axis limits $axis] break
1270                    $inner.min delete 0 end
1271                    $inner.min insert end $min
1272                    $inner.max delete 0 end
1273                    $inner.max insert end $max
1274                }
1275                default {
1276                    # be lenient so we can handle the "focus" case
1277                }
1278            }
1279        }
1280        format {
1281            if {[llength $args] != 3} {
1282                error "wrong # args: should be \"_axis format axis widget value\""
1283            }
1284            set axis [lindex $args 0]
1285            set value [lindex $args 2]
1286
1287            if {[$itk_component(plot) axis cget $axis -logscale]} {
1288                set fmt "%.3g"
1289            } else {
1290                set fmt $_axisPopup(format-$axis)
1291            }
1292            return [format $fmt $value]
1293        }
1294        scale {
1295            if {[llength $args] != 2} {
1296                error "wrong # args: should be \"_axis scale axis type\""
1297            }
1298            set axis [lindex $args 0]
1299            set type [lindex $args 1]
1300
1301            if {$type == "log"} {
1302                catch {$itk_component(plot) axis configure $axis -logscale 1}
1303                # leave format alone in log mode
1304                $itk_component(plot) axis configure $axis -command ""
1305            } else {
1306                catch {$itk_component(plot) axis configure $axis -logscale 0}
1307                # use special formatting for linear mode
1308                $itk_component(plot) axis configure $axis -command \
1309                    [itcl::code $this _axis format $axis]
1310            }
1311        }
1312        default {
1313            error "bad option \"$option\": should be changed, edit, hilite, or format"
1314        }
1315    }
1316}
1317
1318# ----------------------------------------------------------------------
1319# USAGE: _getAxes <curveObj>
1320#
1321# Used internally to figure out the axes used to plot the given
1322# <curveObj>.  Returns a list of the form {x y}, where x is the
1323# x-axis name (x, x2, x3, etc.), and y is the y-axis name.
1324# ----------------------------------------------------------------------
1325itcl::body Rappture::Historesult::_getAxes {xydata} {
1326    # rebuild if needed, so we know about the axes
1327    if {[$_dispatcher ispending !rebuild]} {
1328        $_dispatcher cancel !rebuild
1329        $_dispatcher event -now !rebuild
1330    }
1331
1332    # what is the x axis?  x? x2? x3? ...
1333    set xlabel [$xydata hints xlabel]
1334    if {[info exists _label2axis(x-$xlabel)]} {
1335        set mapx $_label2axis(x-$xlabel)
1336    } else {
1337        set mapx "x"
1338    }
1339
1340    # what is the y axis?  y? y2? y3? ...
1341    set ylabel [$xydata hints ylabel]
1342    if {[info exists _label2axis(y-$ylabel)]} {
1343        set mapy $_label2axis(y-$ylabel)
1344    } else {
1345        set mapy "y"
1346    }
1347
1348    return [list $mapx $mapy]
1349}
1350
1351# ----------------------------------------------------------------------
1352# CONFIGURATION OPTION: -gridcolor
1353# ----------------------------------------------------------------------
1354itcl::configbody Rappture::Historesult::gridcolor {
1355    if {"" == $itk_option(-gridcolor)} {
1356        $itk_component(plot) grid off
1357    } else {
1358        $itk_component(plot) grid configure -color $itk_option(-gridcolor)
1359        $itk_component(plot) grid on
1360    }
1361}
1362
1363# ----------------------------------------------------------------------
1364# CONFIGURATION OPTION: -autocolors
1365# ----------------------------------------------------------------------
1366itcl::configbody Rappture::Historesult::autocolors {
1367    foreach c $itk_option(-autocolors) {
1368        if {[catch {winfo rgb $itk_component(hull) $c}]} {
1369            error "bad color \"$c\""
1370        }
1371    }
1372    if {$_autoColorI >= [llength $itk_option(-autocolors)]} {
1373        set _autoColorI 0
1374    }
1375}
Note: See TracBrowser for help on using the repository browser.