source: branches/1.2/gui/scripts/table.tcl @ 3652

Last change on this file since 3652 was 3330, checked in by gah, 11 years ago

merge (by hand) with Rappture1.2 branch

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