Tcl Library Source Code

Check-in [4c651a5ee7]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Solve a small problem with the math::stats proc (it did not correctly calculate the mean if the given numbers were all integers; now in the correct branch)
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256:4c651a5ee73b5265d34611fd019e1d3bd516f6deefc64635b523fa6c79fc88fd
User & Date: arjenmarkus 2019-04-23 18:52:36
Context
2019-04-23
19:46
Add a new package "quasirandom" for generating quasirandom numbers check-in: 8fdd9b5200 user: arjenmarkus tags: trunk
18:52
Solve a small problem with the math::stats proc (it did not correctly calculate the mean if the given numbers were all integers; now in the correct branch) check-in: 4c651a5ee7 user: arjenmarkus tags: trunk
2019-04-19
17:03
Package consolidation, deprecation, and movement. Tkt [31868eeaff] New: - fileutil::paths Tcl 8.4+ Version 1 - struct::map Tcl 8.4+ Version 1 Deprecated Replacement - configuration struct::map - doctools::config struct::map - doctools::paths fileutil::paths - paths fileutil::paths Updated all packages within Tcllib using the deprecated packages to now use the replacements instead. - doctools::idx::export 0.2.1 (I) - doctools::idx::import 0.2.1 (I) - doctools::toc::export 0.2.1 (I) - doctools::toc::import 0.2.1 (I) - pt::peg::export 1.0.1 (I) - pt::peg::import 1.0.1 (I) For external users reworked the internals of the deprecated packages to be plain wrappers redirecting to their replacements, deprecation stage D1. check-in: 788d248407 user: aku tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/math/ChangeLog.





1
2
3
4
5
6
7




2018-08-04  Arjen Markus <arjenmarkus@users.sourceforge.net>
	* statistics.tcl: Source stat_wasserstein.tcl and stat_logit.tcl - for new commands
	* statistics.test: Add corresponding tests
	* statistics.man: Add description of these commands
	* pkgIndex.tcl: Bump the version to 1.3.0

2018-07-22  Arjen Markus <arjenmarkus@users.sourceforge.net>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
2019-04-18  Arjen Markus <arjenmarkus@users.sourceforge.net>
	* misc.tcl: Add double() to calculation of mean and standard deviation in proc stats (ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9)
	* math.test: Correct the outcome of the test for stats (consequence of ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9)

2018-08-04  Arjen Markus <arjenmarkus@users.sourceforge.net>
	* statistics.tcl: Source stat_wasserstein.tcl and stat_logit.tcl - for new commands
	* statistics.test: Add corresponding tests
	* statistics.man: Add description of these commands
	* pkgIndex.tcl: Bump the version to 1.3.0

2018-07-22  Arjen Markus <arjenmarkus@users.sourceforge.net>

Changes to modules/math/math.test.

214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
} [tcltest::wrongNumArgs math::stats {val1 val2 args} 1]
test math-8.3 { simple math::stats } {
     foreach {a b c} [ math::stats 100 100 100 110 ] { break }
     set a [ expr round($a) ]
     set b [ expr round($b) ]
     set c [ expr round($c) ]
     list $a $b $c
} {102 5 5}

test math-9.1 { math::integrate, insufficient data points } {
     catch { math::integrate {1 10 2 20 3 30 4 40} } msg
     set msg
} "at least 5 x,y pairs must be given"
test math-9.2 { simple math::integrate } {
     math::integrate {1 10 2 20 3 30 4 40 5 50 6 60 7 70 8 80 9 90 10 100}







|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
} [tcltest::wrongNumArgs math::stats {val1 val2 args} 1]
test math-8.3 { simple math::stats } {
     foreach {a b c} [ math::stats 100 100 100 110 ] { break }
     set a [ expr round($a) ]
     set b [ expr round($b) ]
     set c [ expr round($c) ]
     list $a $b $c
} {103 5 5}

test math-9.1 { math::integrate, insufficient data points } {
     catch { math::integrate {1 10 2 20 3 30 4 40} } msg
     set msg
} "at least 5 x,y pairs must be given"
test math-9.2 { simple math::integrate } {
     math::integrate {1 10 2 20 3 30 4 40 5 50 6 60 7 70 8 80 9 90 10 100}

Changes to modules/math/misc.tcl.

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
..
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
...
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
#
#	Collection of math functions.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: misc.tcl,v 1.6 2005/10/10 14:02:47 arjenmarkus Exp $

package require Tcl 8.2		;# uses [lindex $l end-$integer]
namespace eval ::math {
}

# ::math::cov --
................................................................................
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/$N } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
     set sigma [ expr { sqrt($sigma_sq) } ]
     if { $mean != 0.0 } { 
        set cov [ expr { ($sigma/$mean)*100 } ]
     } else {
        return -code error -errorinfo "Cov undefined for data with zero mean" -errorcode {ARITH DOMAIN}
     }
     set cov
}

................................................................................
	return $prev1
    }
}

# ::math::integrate --
#
#	calculate the area under a curve defined by a set of (x,y) data pairs.
#	the x data must increase monotonically throughout the data set for the 
#	calculation to be meaningful, therefore the monotonic condition is
#	tested, and an error is thrown if the x value is found to be
#	decreasing.
#
# Arguments:
#	xy_pairs	list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5
#			data pairs are required, and if the number of data
#			pairs is even, a padding value of (x0, 0) will be
#			added.
# 
# Results:
#	result		A two-element list consisting of the area and error
#			bound (calculation is "Simpson's rule")

proc ::math::integrate { xy_pairs } {
     
     set length [ llength $xy_pairs ]
     
     if { $length < 10 } {
        return -code error "at least 5 x,y pairs must be given"
     }   
     
     ;## are we dealing with x,y pairs?
     if { [ expr {$length % 2} ] } {
        return -code error "unmatched xy pair in input"
     }
     
     ;## are there an even number of pairs?  Augment.
     if { ! [ expr {$length % 4} ] } {
        set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
     }
     set x0   [ lindex $xy_pairs 0     ]
     set x1   [ lindex $xy_pairs 2     ]
     set xn   [ lindex $xy_pairs end-1 ]
     set xnminus1 [ lindex $xy_pairs end-3 ]
    
     if { $x1 < $x0 } {
        return -code error "monotonicity broken by x1"
     }

     if { $xn < $xnminus1 } {
        return -code error "monotonicity broken by xn"
     }   
     
     ;## handle the assymetrical elements 0, n, and n-1.
     set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ]
     set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ]

     set data [ lrange $xy_pairs 2 end-4 ]
     
     set xmax $x1
     set i 1
     foreach {x1 y1 x2 y2} $data {
        incr i
        if { $x1 < $xmax } {
           return -code error "monotonicity broken by x$i"
        }
................................................................................
        set xmax $x1
        incr i
        if { $x2 < $xmax } {
           return -code error "monotonicity broken by x$i"
        }
        set xmax $x2
        set sum [ expr {$sum + (4*$y1) + (2*$y2)} ]
     }   
     
     if { $xmax > $xnminus1 } {
        return -code error "monotonicity broken by xn-1"
     }   
    
     set h [ expr { ( $xn - $x0 ) / $i } ]
     set area [ expr { ( $h / 3.0 ) * $sum } ]
     set err_bound  [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]  
     return [ list $area $err_bound ]
}

# ::math::max --
#
#	Return the maximum of two or more values
#
................................................................................
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/$N } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
     set sigma [ expr { sqrt($sigma_sq) } ]
     set sigma
}     

# ::math::stats --
#
#	Return the mean, standard deviation, and coefficient of variation as
#	percent, as a list.
#
# Arguments:
................................................................................

proc ::math::stats {val1 val2 args} {
     set sum [ expr { $val1+$val2 } ]
     set N [ expr { [ llength $args ] + 2 } ]
     foreach val $args {
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/$N } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
     set sigma [ expr { sqrt($sigma_sq) } ]
     set cov [ expr { ($sigma/$mean)*100 } ]
     return [ list $mean $sigma $cov ]
}

# ::math::sum --
#







|







 







|

|







 







|









|





|

|


|
|




|








|






|
|





|







 







|
|


|
|


|







 







|


|







 







|




|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
..
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
...
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
...
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
#
#	Collection of math functions.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: misc.tcl,v 1.6 2005/10/10 14:02:47 arjenmarkus Exp $

package require Tcl 8.2		;# uses [lindex $l end-$integer]
namespace eval ::math {
}

# ::math::cov --
................................................................................
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/$N } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/($N-1) } ]
     set sigma [ expr { sqrt($sigma_sq) } ]
     if { $mean != 0.0 } {
        set cov [ expr { ($sigma/$mean)*100 } ]
     } else {
        return -code error -errorinfo "Cov undefined for data with zero mean" -errorcode {ARITH DOMAIN}
     }
     set cov
}

................................................................................
	return $prev1
    }
}

# ::math::integrate --
#
#	calculate the area under a curve defined by a set of (x,y) data pairs.
#	the x data must increase monotonically throughout the data set for the
#	calculation to be meaningful, therefore the monotonic condition is
#	tested, and an error is thrown if the x value is found to be
#	decreasing.
#
# Arguments:
#	xy_pairs	list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5
#			data pairs are required, and if the number of data
#			pairs is even, a padding value of (x0, 0) will be
#			added.
#
# Results:
#	result		A two-element list consisting of the area and error
#			bound (calculation is "Simpson's rule")

proc ::math::integrate { xy_pairs } {

     set length [ llength $xy_pairs ]

     if { $length < 10 } {
        return -code error "at least 5 x,y pairs must be given"
     }

     ;## are we dealing with x,y pairs?
     if { [ expr {$length % 2} ] } {
        return -code error "unmatched xy pair in input"
     }

     ;## are there an even number of pairs?  Augment.
     if { ! [ expr {$length % 4} ] } {
        set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
     }
     set x0   [ lindex $xy_pairs 0     ]
     set x1   [ lindex $xy_pairs 2     ]
     set xn   [ lindex $xy_pairs end-1 ]
     set xnminus1 [ lindex $xy_pairs end-3 ]

     if { $x1 < $x0 } {
        return -code error "monotonicity broken by x1"
     }

     if { $xn < $xnminus1 } {
        return -code error "monotonicity broken by xn"
     }

     ;## handle the assymetrical elements 0, n, and n-1.
     set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ]
     set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ]

     set data [ lrange $xy_pairs 2 end-4 ]

     set xmax $x1
     set i 1
     foreach {x1 y1 x2 y2} $data {
        incr i
        if { $x1 < $xmax } {
           return -code error "monotonicity broken by x$i"
        }
................................................................................
        set xmax $x1
        incr i
        if { $x2 < $xmax } {
           return -code error "monotonicity broken by x$i"
        }
        set xmax $x2
        set sum [ expr {$sum + (4*$y1) + (2*$y2)} ]
     }

     if { $xmax > $xnminus1 } {
        return -code error "monotonicity broken by xn-1"
     }

     set h [ expr { ( $xn - $x0 ) / $i } ]
     set area [ expr { ( $h / 3.0 ) * $sum } ]
     set err_bound  [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]
     return [ list $area $err_bound ]
}

# ::math::max --
#
#	Return the maximum of two or more values
#
................................................................................
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/$N } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/($N-1) } ]
     set sigma [ expr { sqrt($sigma_sq) } ]
     set sigma
}

# ::math::stats --
#
#	Return the mean, standard deviation, and coefficient of variation as
#	percent, as a list.
#
# Arguments:
................................................................................

proc ::math::stats {val1 val2 args} {
     set sum [ expr { $val1+$val2 } ]
     set N [ expr { [ llength $args ] + 2 } ]
     foreach val $args {
        set sum [ expr { $sum+$val } ]
     }
     set mean [ expr { $sum/double($N) } ]
     set sigma_sq 0
     foreach val [ concat $val1 $val2 $args ] {
        set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
     }
     set sigma_sq [ expr { $sigma_sq/double($N-1) } ]
     set sigma [ expr { sqrt($sigma_sq) } ]
     set cov [ expr { ($sigma/$mean)*100 } ]
     return [ list $mean $sigma $cov ]
}

# ::math::sum --
#