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

Last change on this file since 818 was 818, checked in by gah, 13 years ago

still in development

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