source: trunk/gui/scripts/table.tcl @ 13

Last change on this file since 13 was 13, checked in by mmc, 16 years ago

Many improvements, including a new energy level viewer
for Huckel-IV. Added support for a new <boolean> type.
Fixed the cloud/field stuff so that when a cloud is 1D,
it reverts to BLT vectors so it will plot correctly.
Fixed the install script to work better on Windows.

File size: 7.5 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: table - extracts data from an XML description of a table
3#
4#  This object represents one table in an XML description of a table.
5#  It simplifies the process of extracting data representing columns
6#  in the table.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2005
10#  Purdue Research Foundation, West Lafayette, IN
11# ======================================================================
12package require Itcl
13
14namespace eval Rappture { # forward declaration }
15
16itcl::class Rappture::Table {
17    constructor {xmlobj path} { # defined below }
18    destructor { # defined below }
19
20    public method rows {}
21    public method columns {args}
22    public method values {args}
23    public method limits {col}
24    public method hints {{key ""}}
25
26    private variable _xmlobj ""  ;# ref to lib obj with curve data
27    private variable _table ""   ;# lib obj representing this table
28    private variable _tuples ""  ;# list of tuples with table data
29}
30
31# ----------------------------------------------------------------------
32# CONSTRUCTOR
33# ----------------------------------------------------------------------
34itcl::body Rappture::Table::constructor {xmlobj path} {
35    if {![Rappture::library isvalid $xmlobj]} {
36        error "bad value \"$xmlobj\": should be Rappture::library"
37    }
38    set _table [$xmlobj element -as object $path]
39
40    #
41    # Load data from the table and store in the tuples.
42    #
43    set _tuples [Rappture::Tuples ::#auto]
44    foreach cname [$_table children -type column] {
45        set label [$_table get $cname.label]
46        $_tuples column insert end -name $cname -label $label
47    }
48
49    set cols [llength [$_tuples column names]]
50    set nline 1
51    foreach line [split [$_table get data] \n] {
52        if {[llength $line] == 0} {
53            continue
54        }
55        if {[llength $line] != $cols} {
56            error "bad data at line $nline: expected $cols columns but got \"[string trim $line]\""
57        }
58        $_tuples insert end $line
59        incr nline
60    }
61}
62
63# ----------------------------------------------------------------------
64# DESTRUCTOR
65# ----------------------------------------------------------------------
66itcl::body Rappture::Table::destructor {} {
67    itcl::delete object $_tuples
68    itcl::delete object $_table
69    # don't destroy the _xmlobj! we don't own it!
70}
71
72# ----------------------------------------------------------------------
73# USAGE: rows
74#
75# Returns the number of rows of information in this table.
76# ----------------------------------------------------------------------
77itcl::body Rappture::Table::rows {} {
78    return [$_tuples size]
79}
80
81# ----------------------------------------------------------------------
82# USAGE: columns ?-component|-label|-units? ?<pos>?
83#
84# Returns information about the columns associated with this table.
85# ----------------------------------------------------------------------
86itcl::body Rappture::Table::columns {args} {
87    Rappture::getopts args params {
88        flag switch -component
89        flag switch -label default
90        flag switch -units
91    }
92    if {[llength $args] == 0} {
93        set cols [llength [$_tuples column names]]
94        set plist ""
95        for {set i 0} {$i < $cols} {incr i} {
96            lappend plist $i
97        }
98    } elseif {[llength $args] == 1} {
99        set p [lindex $args 0]
100        if {[string is integer $p]} {
101            lappend plist $p
102        } else {
103            set pos [lsearch -exact [$_tuples column names] $p]
104            if {$pos < 0} {
105                error "bad column \"$p\": should be column name or integer index"
106            }
107            lappend plist $pos
108        }
109    } else {
110        error "wrong # args: should be \"columns ?-component|-label|-units? ?pos?\""
111    }
112
113    set rlist ""
114    switch -- $params(switch) {
115        -component {
116            set names [$_tuples column names]
117            foreach p $plist {
118                lappend rlist [lindex $names $p]
119            }
120        }
121        -label {
122            set names [$_tuples column names]
123            foreach p $plist {
124                set name [lindex $names $p]
125                catch {unset opts}
126                array set opts [$_tuples column info $name]
127                lappend rlist $opts(-label)
128            }
129        }
130        -units {
131            set names [$_tuples column names]
132            foreach p $plist {
133                set comp [lindex $names $p]
134                lappend rlist [$_table get $comp.units]
135            }
136        }
137    }
138    return $rlist
139}
140
141# ----------------------------------------------------------------------
142# USAGE: values ?-row <index>? ?-column <index>?
143#
144# Returns a single value or a list of values for data in this table.
145# If a particular -row and -column is specified, then it returns
146# a single value for that row/column.  If either the -row or the
147# -column is specified, then it returns a list of values in that
148# row or column.  With no args, it returns all values in the table.
149# ----------------------------------------------------------------------
150itcl::body Rappture::Table::values {args} {
151    Rappture::getopts args params {
152        value -row ""
153        value -column ""
154    }
155    if {[llength $args] > 0} {
156        error "wrong # args: should be \"values ?-row r? ?-column c?\""
157    }
158    if {"" == $params(-row) && "" == $params(-column)} {
159        return [$_tuples get]
160    } elseif {"" == $params(-column)} {
161        return [lindex [$_tuples get $params(-row)] 0]
162    }
163
164    if {[string is integer $params(-column)]} {
165        set col [lindex [$_tuples column names] $params(-column)]
166    } else {
167        set col $params(-column)
168        if {"" == [$_tuples column names $col]} {
169            error "bad column name \"$col\": should be [join [$_tuples column names] {, }]"
170        }
171    }
172
173    if {"" == $params(-row)} {
174        # return entire column
175        return [$_tuples get -format $col]
176    }
177    # return a particular cell
178    return [$_tuples get -format $col $params(-row)]
179}
180
181# ----------------------------------------------------------------------
182# USAGE: limits <column>
183#
184# Returns the {min max} limits of the numerical values in the
185# specified <column>, which can be either an integer index to
186# a column or a column name.
187# ----------------------------------------------------------------------
188itcl::body Rappture::Table::limits {column} {
189    set min ""
190    set max ""
191    foreach v [values -column $column] {
192        if {"" == $min} {
193            set min $v
194            set max $v
195        } else {
196            if {$v < $min} { set min $v }
197            if {$v > $max} { set max $v }
198        }
199    }
200    return [list $min $max]
201}
202
203# ----------------------------------------------------------------------
204# USAGE: hints ?<keyword>?
205#
206# Returns a list of key/value pairs for various hints about plotting
207# this table.  If a particular <keyword> is specified, then it returns
208# the hint for that <keyword>, if it exists.
209# ----------------------------------------------------------------------
210itcl::body Rappture::Table::hints {{keyword ""}} {
211    foreach {key path} {
212        label   about.label
213        color   about.color
214        style   about.style
215    } {
216        set str [$_table get $path]
217        if {"" != $str} {
218            set hints($key) $str
219        }
220    }
221
222    if {$keyword != ""} {
223        if {[info exists hints($keyword)]} {
224            return $hints($keyword)
225        }
226        return ""
227    }
228    return [array get hints]
229}
Note: See TracBrowser for help on using the repository browser.