source: branches/r9/gui/scripts/resultset.tcl @ 4988

Last change on this file since 4988 was 3770, checked in by mmc, 11 years ago

Fixed a problem with the resultset that surfaced during the "letters"
assignment in the summer bootcamp. With two results, the "Number of
Words" plot would show one result but not the other. The problem was
that one parameter would be something like "abc", and the other would
have spaces like "abc def". The resultset was not reporting diffs
properly for any value like that with spaces in it.

Also fixed a small problem in the tester diff method for boolean values.

File size: 20.9 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: ResultSet - set of XML objects for simulated results
4#
5#  This data structure collects all of the simulated results
6#  produced by a series of tool runs.  It is used by the Analyzer,
7#  ResultSelector, and other widgets to keep track of all known runs
8#  and visualize the result that is currently selected.  Each run
9#  has an index number ("#1", "#2", "#3", etc.) that can be used to
10#  label the run and refer to it later.
11# ======================================================================
12#  AUTHOR:  Michael McLennan, Purdue University
13#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
14#
15#  See the file "license.terms" for information on usage and
16#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17# ======================================================================
18package require Itcl
19
20itcl::class Rappture::ResultSet {
21    constructor {args} { # defined below }
22    destructor { # defined below }
23
24    public method add {xmlobj}
25    public method clear {{xmlobj ""}}
26    public method diff {option args}
27    public method find {collist vallist}
28    public method get {collist xmlobj}
29    public method contains {xmlobj}
30    public method size {}
31
32    public method notify {option args}
33    protected method _notifyHandler {args}
34
35    protected method _addOneResult {tuples xmlobj {simnum ""}}
36
37    private variable _dispatcher ""  ;# dispatchers for !events
38    private variable _results ""     ;# tuple of known results
39    private variable _resultnum 0    ;# counter for result #1, #2, etc.
40    private variable _notify         ;# info used for notify command
41}
42                                                                               
43# ----------------------------------------------------------------------
44# CONSTRUCTOR
45# ----------------------------------------------------------------------
46itcl::body Rappture::ResultSet::constructor {args} {
47    # create a dispatcher for events
48    Rappture::dispatcher _dispatcher
49    $_dispatcher register !change
50    $_dispatcher dispatch $this !change \
51        [itcl::code $this _notifyHandler]
52
53    # create a list of tuples for data
54    set _results [Rappture::Tuples ::#auto]
55    $_results column insert end -name xmlobj -label "top-level XML object"
56    $_results column insert end -name simnum -label "simulation number"
57
58    # clear notification info
59    set _notify(ALL) ""
60
61    eval configure $args
62}
63
64# ----------------------------------------------------------------------
65# DESTRUCTOR
66# ----------------------------------------------------------------------
67itcl::body Rappture::ResultSet::destructor {} {
68    clear
69    itcl::delete object $_results
70}
71
72# ----------------------------------------------------------------------
73# USAGE: add <xmlobj>
74#
75# Adds a new result to this result set.  Scans through all existing
76# results to look for a difference compared to previous results.
77# Returns the simulation number (#1, #2, #3, etc.) of this new result
78# to the caller.  The various data objects for this result set should
79# be added to their result viewers at the same index.
80# ----------------------------------------------------------------------
81itcl::body Rappture::ResultSet::add {xmlobj} {
82    set xmlobj0 [$_results get -format xmlobj end]
83    if {$xmlobj0 eq ""} {
84        #
85        # If this is the first result, then there are no diffs.
86        # Add it right in.
87        #
88        set simnum "#[incr _resultnum]"
89        $_results insert end [list $xmlobj $simnum]
90    } else {
91        #
92        # For all later results, find the diffs and add any new columns
93        # into the results tuple.  The latest result is the most recent.
94        #
95        set simnum [_addOneResult $_results $xmlobj]
96    }
97
98    # make sure we fix up associated controls
99    $_dispatcher event -now !change op add what $xmlobj
100
101    return $simnum
102}
103
104# ----------------------------------------------------------------------
105# USAGE: clear ?<xmlobj>?
106#
107# Clears one or all results in this result set.  If no specific
108# result object is specified, then all results are cleared.
109# ----------------------------------------------------------------------
110itcl::body Rappture::ResultSet::clear {{xmlobj ""}} {
111    if {$xmlobj ne ""} {
112        #
113        # Delete just one result.  Look for the result among the
114        # tuples and remove it.  Then, rebuild all of the tuples
115        # by scanning back through them and building them back up.
116        # This will rebuild the columns/controls as they should
117        # be now, removing anything that is no longer necessary.
118        #
119        set irun [$_results find -format xmlobj $xmlobj]
120        if {[llength $irun] == 1} {
121            # grab a description of what we're about to delete
122            set dlist [list simnum [$_results get -format simnum $irun]]
123            foreach col [lrange [$_results column names] 2 end] {
124                set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
125                lappend dlist $col $raw  ;# use "raw" (user-readable) label
126            }
127
128            # delete this from the tuples of all results
129            itcl::delete object $xmlobj
130            $_results delete $irun
131
132            set new [Rappture::Tuples ::#auto]
133            $new column insert end -name xmlobj -label "top-level XML object"
134            $new column insert end -name simnum -label "simulation number"
135
136            for {set n 0} {$n < [$_results size]} {incr n} {
137                set rec [lindex [$_results get -format {xmlobj simnum} $n] 0]
138                foreach {obj num} $rec break
139                if {$n == 0} {
140                    $new insert end [list $obj $num]
141                } else {
142                    _addOneResult $new $obj $num
143                }
144            }
145
146            # plug in the new set of rebuilt tuples
147            itcl::delete object $_results
148            set _results $new
149
150            # make sure we fix up associated controls at some point
151            $_dispatcher event -now !change op clear what $dlist
152        }
153    } else {
154        #
155        # Delete all results.
156        #
157        for {set irun 0} {$irun < [$_results size]} {incr irun} {
158            set xo [$_results get -format xmlobj $irun]
159            itcl::delete object $xo
160        }
161        $_results delete 0 end
162
163        # make sure we fix up associated controls at some point
164        $_dispatcher event -now !change op clear what all
165    }
166
167    if {[$_results size] == 0} {
168        # no results left?  then reset to a clean state
169        eval $_results column delete [lrange [$_results column names] 2 end]
170        set _resultnum 0
171    }
172}
173
174# ----------------------------------------------------------------------
175# USAGE: diff names
176# USAGE: diff values <column> ?<which>?
177#
178# Returns information about the diffs in the current set of known
179# results.  The "diff names" returns a list of column names for
180# parameters that have diffs.  (These are the columns in the tuples.)
181#
182# The "diff values" returns the various values associated with a
183# particular <column> name.  If the optional <which> is specified,
184# then it is treated as an index into the list of values--0 for the
185# first value, 1 for the second, etc.  Each value is returned as
186# a list with two words.  The first is the the label associated with
187# the value.  The second is the normalized (numeric) value, which can
188# be sorted to get a particular ordering.
189# ----------------------------------------------------------------------
190itcl::body Rappture::ResultSet::diff {option args} {
191    switch -- $option {
192        names {
193            return [$_results column names]
194        }
195        values {
196            if {[llength $args] < 1} {
197                error "wrong # args: should be \"diff values col ?which?\""
198            }
199            set col [lindex $args 0]
200
201            set which "all"
202            if {[llength $args] > 1} {
203                set which [lindex $args 1]
204            }
205
206            set rlist ""
207            # build an array of normalized values and their labels
208            if {$col == "simnum"} {
209                set nruns [$_results size]
210                for {set n 0} {$n < $nruns} {incr n} {
211                    set simnum [$_results get -format simnum $n]
212                    lappend rlist $simnum $n
213                }
214            } else {
215                set havenums 1
216                foreach rec [$_results get -format [list xmlobj $col]] {
217                    set xo [lindex $rec 0]
218                    set v [lindex $rec 1]
219                    foreach {raw norm} \
220                        [Rappture::LibraryObj::value $xo $col] break
221
222                    if {![info exists unique($v)]} {
223                        # keep only unique label strings
224                        set unique($v) $norm
225                    }
226                    if {$havenums && ![string is double $norm]} {
227                        set havenums 0
228                    }
229                }
230
231                if {!$havenums} {
232                    # don't have normalized nums? then sort and create nums
233                    set rlist ""
234                    set n 0
235                    foreach val [lsort -dictionary [array names unique]] {
236                        lappend rlist $val [incr n]
237                    }
238                } else {
239                    set rlist [array get unique]
240                }
241            }
242
243            if {$which eq "all"} {
244                return $rlist
245            }
246
247            # treat the "which" parameter as an XML object
248            set irun [lindex [$_results find -format xmlobj $which] 0]
249            if {$irun ne ""} {
250                set val [lindex [$_results get -format $col $irun] 0]
251                array set val2norm $rlist
252                if {[info exists val2norm($val)]} {
253                    return [list $val $val2norm($val)]
254                }
255            }
256        }
257        default {
258            error "bad option \"$option\": should be names or values"
259        }
260    }
261}
262
263# ----------------------------------------------------------------------
264# USAGE: find <columnList> <valueList>
265#
266# Searches through the results for a set of tuple values that match
267# the <valueList> for the given <columnList>.  Returns a list of
268# matching xml objects or "" if there is no match.  If the <valueList>
269# is *, then it returns a list of all xml objects.
270# ----------------------------------------------------------------------
271itcl::body Rappture::ResultSet::find {collist vallist} {
272    if {$vallist eq "*"} {
273        return [$_results get -format xmlobj]
274    }
275
276    set rlist ""
277    foreach irun [$_results find -format $collist -- $vallist] {
278        lappend rlist [$_results get -format xmlobj $irun]
279    }
280    return $rlist
281}
282
283# ----------------------------------------------------------------------
284# USAGE: get <columnList> <xmlobj>
285#
286# Returns values for the specified <columnList> for the given <xmlobj>.
287# This is a way of querying associated data for the given object.
288# ----------------------------------------------------------------------
289itcl::body Rappture::ResultSet::get {collist xmlobj} {
290    set irun [lindex [$_results find -format xmlobj $xmlobj] 0]
291    if {$irun ne ""} {
292        return [lindex [$_results get -format $collist $irun] 0]
293    }
294    return ""
295}
296
297# ----------------------------------------------------------------------
298# USAGE: contains <xmlobj>
299#
300# Checks to see if the given <xmlobj> is already represented by
301# some result in this result set.  This comes in handy when checking
302# to see if an input case is already covered.
303#
304# Returns 1 if the result set already contains this result, and
305# 0 otherwise.
306# ----------------------------------------------------------------------
307itcl::body Rappture::ResultSet::contains {xmlobj} {
308    # no results? then this must be new
309    if {[$_results size] == 0} {
310        return 0
311    }
312
313    #
314    # Compare this new object against the last XML object in the
315    # results set.  If it has a difference, make sure that there
316    # is a column to represent the quantity with the difference.
317    #
318    set xmlobj0 [$_results get -format xmlobj end]
319    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
320        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
321            continue
322        }
323        if {$op == "+" || $op == "-"} {
324            # ignore differences where parameters come and go
325            # such differences make it hard to work controls
326            continue
327        }
328        if {[$_results column names $vpath] == ""} {
329            # no column for this quantity yet
330            return 0
331        }
332    }
333
334    #
335    # If we got this far, then look through existing results for
336    # matching tuples, then check each one for diffs.
337    #
338    set format ""
339    set tuple ""
340    foreach col [lrange [$_results column names] 2 end] {
341        lappend format $col
342        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
343        lappend tuple $raw  ;# use the "raw" (user-readable) label
344    }
345    if {[llength $format] > 0} {
346        set ilist [$_results find -format $format -- $tuple]
347    } else {
348        set ilist 0  ;# no diffs -- must match first entry
349    }
350
351    foreach i $ilist {
352        set xmlobj0 [$_results get -format xmlobj $i]
353        set diffs [$xmlobj0 diff $xmlobj]
354        if {[llength $diffs] == 0} {
355            # no diffs -- already contained here
356            return 1
357        }
358    }
359
360    # must be some differences
361    return 0
362}
363
364
365# ----------------------------------------------------------------------
366# USAGE: size
367#
368# Returns the number of results currently stored in the set.
369# ----------------------------------------------------------------------
370itcl::body Rappture::ResultSet::size {} {
371    return [$_results size]
372}
373
374# ----------------------------------------------------------------------
375# USAGE: notify add <client> ?!event !event ...? <command>
376# USAGE: notify get ?<client>? ?!event?
377# USAGE: notify remove <client> ?!event !event ...?
378#
379# Clients use this to add/remove requests for notifications about
380# various events that signal changes to the data in each ResultSet.
381#
382# The "notify add" operation takes a <client> name (any unique string
383# identifying the client), an optional list of events, and the <command>
384# that should be called for the callback.
385#
386# The "notify get" command returns information about clients and their
387# registered callbacks.  With no args, it returns a list of <client>
388# names.  If the <client> is specified, it returns a list of !events.
389# If the <client> and !event is specified, it returns the <command>.
390#
391# The "notify remove" command removes any callback associated with
392# a given <client>.  If no particular !events are specified, then it
393# removes callbacks for all events.
394# ----------------------------------------------------------------------
395itcl::body Rappture::ResultSet::notify {option args} {
396    set allEvents {!change}
397    switch -- $option {
398        add {
399            if {[llength $args] < 2} {
400                error "wrong # args: should be \"notify add caller ?!event !event ...? command"
401            }
402            set caller [lindex $args 0]
403            set command [lindex $args end]
404            if {[llength $args] > 2} {
405                set events [lrange $args 1 end-1]
406            } else {
407                set events $allEvents
408            }
409
410            foreach name $events {
411                if {[lsearch -exact $allEvents $name] < 0} {
412                    error "bad event \"$name\": should be [join $allEvents ,]"
413                }
414                if {[lsearch $_notify(ALL) $caller] < 0} {
415                    lappend _notify(ALL) $caller
416                }
417                set _notify($caller-$name) $command
418            }
419        }
420        get {
421            switch -- [llength $args] {
422                0 {
423                    return $_notify(ALL)
424                }
425                1 {
426                    set caller [lindex $args 0]
427                    set rlist ""
428                    foreach key [array names _notify $caller-*] {
429                        lappend rlist [lindex [split $key -] end]
430                    }
431                    return $rlist
432                }
433                2 {
434                    set caller [lindex $args 0]
435                    set name [lindex $args 1]
436                    if {[info exists _notify($caller-$name)]} {
437                        return $_notify($caller-$name)
438                    }
439                    return ""
440                }
441                default {
442                    error "wrong # args: should be \"notify get ?caller? ?!event?\""
443                }
444            }
445        }
446        remove {
447            if {[llength $args] < 1} {
448                error "wrong # args: should be \"notify remove caller ?!event !event ...?"
449            }
450            set caller [lindex $args 0]
451            if {[llength $args] > 1} {
452                set events [lrange $args 1 end]
453            } else {
454                set events $allEvents
455            }
456
457            foreach name $events {
458                catch {unset _notify($caller-$name)}
459            }
460            if {[llength [array names _notify $caller-*]] == 0} {
461                set i [lsearch $_notify(ALL) $caller]
462                if {$i >= 0} {
463                    set _notify(ALL) [lreplace $_notify(ALL) $i $i]
464                }
465            }
466        }
467        default {
468            error "wrong # args: should be add, get, remove"
469        }
470    }
471}
472
473# ----------------------------------------------------------------------
474# USAGE: _notifyHandler ?<eventArgs>...?
475#
476# Called automatically whenever a !change event is triggered in this
477# object.  Scans through the list of clients that want to receive this
478# event and executes each of their callbacks.
479# ----------------------------------------------------------------------
480itcl::body Rappture::ResultSet::_notifyHandler {args} {
481    array set data $args
482    set event $data(event)
483
484    foreach caller $_notify(ALL) {
485        if {[info exists _notify($caller-$event)]} {
486            if {[catch {uplevel #0 $_notify($caller-$event) $args} result]} {
487                # anything go wrong? then throw a background error
488                bgerror "$result\n(while dispatching $event to $caller)"
489            }
490        }
491    }
492}
493
494# ----------------------------------------------------------------------
495# USAGE: _addOneResult <tuples> <xmlobj> ?<simNum>?
496#
497# Used internally to add one new <xmlobj> to the given <tuples>
498# object.  If the new xmlobj contains different input parameters
499# that are not already columns in the tuple, then this routine
500# creates the new columns.  If the optional <simNum> is specified,
501# then it is added as the simulation number #1, #2, #3, etc.  If
502# not, then the new object is automatically numbered.
503# ----------------------------------------------------------------------
504itcl::body Rappture::ResultSet::_addOneResult {tuples xmlobj {simnum ""}} {
505    #
506    # Compare this new object against the last XML object in the
507    # results set.  If it has a difference, make sure that there
508    # is a column to represent the quantity with the difference.
509    #
510    set xmlobj0 [$tuples get -format xmlobj end]
511    foreach {op vpath oldval newval} [$xmlobj0 diff $xmlobj] {
512        if {[$xmlobj get $vpath.about.diffs] == "ignore"} {
513            continue
514        }
515        if {$op == "+" || $op == "-"} {
516            # ignore differences where parameters come and go
517            # such differences make it hard to work controls
518            continue
519        }
520
521        # make sure that these values really are different
522        set oldval [lindex [Rappture::LibraryObj::value $xmlobj0 $vpath] 0]
523        set newval [lindex [Rappture::LibraryObj::value $xmlobj $vpath] 0]
524
525        if {$oldval != $newval && [$tuples column names $vpath] == ""} {
526            # no column for this quantity yet
527            $tuples column insert end -name $vpath -default $oldval
528        }
529    }
530
531    # build a tuple for this new object
532    set cols ""
533    set tuple ""
534    foreach col [lrange [$tuples column names] 2 end] {
535        lappend cols $col
536        set raw [lindex [Rappture::LibraryObj::value $xmlobj $col] 0]
537        lappend tuple $raw  ;# use the "raw" (user-readable) label
538    }
539
540    # find a matching tuple? then replace it -- only need one
541    if {[llength $cols] > 0} {
542        set ilist [$tuples find -format $cols -- $tuple]
543    } else {
544        set ilist 0  ;# no diffs -- must match first entry
545    }
546
547    # add all remaining columns for this new entry
548    set tuple [linsert $tuple 0 $xmlobj]
549    set cols [linsert $cols 0 "xmlobj"]
550
551    if {[llength $ilist] > 0} {
552        if {[llength $ilist] > 1} {
553            error "why so many matching results?"
554        }
555
556        # overwrite the first matching entry
557        # start by freeing the old result
558        set index [lindex $ilist 0]
559        set xo [$tuples get -format xmlobj $index]
560        itcl::delete object $xo
561
562        # put this new result in its place
563        $tuples put -format $cols $index $tuple
564        set simnum [$tuples get -format simnum $index]
565    } else {
566        if {$simnum eq ""} {
567            set simnum "#[incr _resultnum]"
568        }
569        set tuple [linsert $tuple 1 $simnum]
570        $tuples insert end $tuple
571    }
572    return $simnum
573}
Note: See TracBrowser for help on using the repository browser.