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 [email protected]
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 Side-by-Side Diffs Ignore Whitespace Patch

Changes to modules/math/ChangeLog.

            1  +2019-04-18  Arjen Markus <[email protected]>
            2  +	* misc.tcl: Add double() to calculation of mean and standard deviation in proc stats (ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9)
            3  +	* math.test: Correct the outcome of the test for stats (consequence of ticket 0a030f850d4e3fc05da98aa954a6ec1b16e655d9)
            4  +
     1      5   2018-08-04  Arjen Markus <[email protected]>
     2      6   	* statistics.tcl: Source stat_wasserstein.tcl and stat_logit.tcl - for new commands
     3      7   	* statistics.test: Add corresponding tests
     4      8   	* statistics.man: Add description of these commands
     5      9   	* pkgIndex.tcl: Bump the version to 1.3.0
     6     10   
     7     11   2018-07-22  Arjen Markus <[email protected]>

Changes to modules/math/math.test.

   214    214   } [tcltest::wrongNumArgs math::stats {val1 val2 args} 1]
   215    215   test math-8.3 { simple math::stats } {
   216    216        foreach {a b c} [ math::stats 100 100 100 110 ] { break }
   217    217        set a [ expr round($a) ]
   218    218        set b [ expr round($b) ]
   219    219        set c [ expr round($c) ]
   220    220        list $a $b $c
   221         -} {102 5 5}
          221  +} {103 5 5}
   222    222   
   223    223   test math-9.1 { math::integrate, insufficient data points } {
   224    224        catch { math::integrate {1 10 2 20 3 30 4 40} } msg
   225    225        set msg
   226    226   } "at least 5 x,y pairs must be given"
   227    227   test math-9.2 { simple math::integrate } {
   228    228        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      2   #
     3      3   #	Collection of math functions.
     4      4   #
     5      5   # Copyright (c) 1998-2000 by Ajuba Solutions.
     6      6   #
     7      7   # See the file "license.terms" for information on usage and redistribution
     8      8   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
     9         -# 
            9  +#
    10     10   # RCS: @(#) $Id: misc.tcl,v 1.6 2005/10/10 14:02:47 arjenmarkus Exp $
    11     11   
    12     12   package require Tcl 8.2		;# uses [lindex $l end-$integer]
    13     13   namespace eval ::math {
    14     14   }
    15     15   
    16     16   # ::math::cov --
................................................................................
    32     32           set sum [ expr { $sum+$val } ]
    33     33        }
    34     34        set mean [ expr { $sum/$N } ]
    35     35        set sigma_sq 0
    36     36        foreach val [ concat $val1 $val2 $args ] {
    37     37           set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
    38     38        }
    39         -     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
           39  +     set sigma_sq [ expr { $sigma_sq/($N-1) } ]
    40     40        set sigma [ expr { sqrt($sigma_sq) } ]
    41         -     if { $mean != 0.0 } { 
           41  +     if { $mean != 0.0 } {
    42     42           set cov [ expr { ($sigma/$mean)*100 } ]
    43     43        } else {
    44     44           return -code error -errorinfo "Cov undefined for data with zero mean" -errorcode {ARITH DOMAIN}
    45     45        }
    46     46        set cov
    47     47   }
    48     48   
................................................................................
    70     70   	return $prev1
    71     71       }
    72     72   }
    73     73   
    74     74   # ::math::integrate --
    75     75   #
    76     76   #	calculate the area under a curve defined by a set of (x,y) data pairs.
    77         -#	the x data must increase monotonically throughout the data set for the 
           77  +#	the x data must increase monotonically throughout the data set for the
    78     78   #	calculation to be meaningful, therefore the monotonic condition is
    79     79   #	tested, and an error is thrown if the x value is found to be
    80     80   #	decreasing.
    81     81   #
    82     82   # Arguments:
    83     83   #	xy_pairs	list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5
    84     84   #			data pairs are required, and if the number of data
    85     85   #			pairs is even, a padding value of (x0, 0) will be
    86     86   #			added.
    87         -# 
           87  +#
    88     88   # Results:
    89     89   #	result		A two-element list consisting of the area and error
    90     90   #			bound (calculation is "Simpson's rule")
    91     91   
    92     92   proc ::math::integrate { xy_pairs } {
    93         -     
           93  +
    94     94        set length [ llength $xy_pairs ]
    95         -     
           95  +
    96     96        if { $length < 10 } {
    97     97           return -code error "at least 5 x,y pairs must be given"
    98         -     }   
    99         -     
           98  +     }
           99  +
   100    100        ;## are we dealing with x,y pairs?
   101    101        if { [ expr {$length % 2} ] } {
   102    102           return -code error "unmatched xy pair in input"
   103    103        }
   104         -     
          104  +
   105    105        ;## are there an even number of pairs?  Augment.
   106    106        if { ! [ expr {$length % 4} ] } {
   107    107           set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
   108    108        }
   109    109        set x0   [ lindex $xy_pairs 0     ]
   110    110        set x1   [ lindex $xy_pairs 2     ]
   111    111        set xn   [ lindex $xy_pairs end-1 ]
   112    112        set xnminus1 [ lindex $xy_pairs end-3 ]
   113         -    
          113  +
   114    114        if { $x1 < $x0 } {
   115    115           return -code error "monotonicity broken by x1"
   116    116        }
   117    117   
   118    118        if { $xn < $xnminus1 } {
   119    119           return -code error "monotonicity broken by xn"
   120         -     }   
   121         -     
          120  +     }
          121  +
   122    122        ;## handle the assymetrical elements 0, n, and n-1.
   123    123        set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ]
   124    124        set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ]
   125    125   
   126    126        set data [ lrange $xy_pairs 2 end-4 ]
   127         -     
          127  +
   128    128        set xmax $x1
   129    129        set i 1
   130    130        foreach {x1 y1 x2 y2} $data {
   131    131           incr i
   132    132           if { $x1 < $xmax } {
   133    133              return -code error "monotonicity broken by x$i"
   134    134           }
................................................................................
   135    135           set xmax $x1
   136    136           incr i
   137    137           if { $x2 < $xmax } {
   138    138              return -code error "monotonicity broken by x$i"
   139    139           }
   140    140           set xmax $x2
   141    141           set sum [ expr {$sum + (4*$y1) + (2*$y2)} ]
   142         -     }   
   143         -     
          142  +     }
          143  +
   144    144        if { $xmax > $xnminus1 } {
   145    145           return -code error "monotonicity broken by xn-1"
   146         -     }   
   147         -    
          146  +     }
          147  +
   148    148        set h [ expr { ( $xn - $x0 ) / $i } ]
   149    149        set area [ expr { ( $h / 3.0 ) * $sum } ]
   150         -     set err_bound  [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]  
          150  +     set err_bound  [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]
   151    151        return [ list $area $err_bound ]
   152    152   }
   153    153   
   154    154   # ::math::max --
   155    155   #
   156    156   #	Return the maximum of two or more values
   157    157   #
................................................................................
   281    281           set sum [ expr { $sum+$val } ]
   282    282        }
   283    283        set mean [ expr { $sum/$N } ]
   284    284        set sigma_sq 0
   285    285        foreach val [ concat $val1 $val2 $args ] {
   286    286           set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
   287    287        }
   288         -     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
          288  +     set sigma_sq [ expr { $sigma_sq/($N-1) } ]
   289    289        set sigma [ expr { sqrt($sigma_sq) } ]
   290    290        set sigma
   291         -}     
          291  +}
   292    292   
   293    293   # ::math::stats --
   294    294   #
   295    295   #	Return the mean, standard deviation, and coefficient of variation as
   296    296   #	percent, as a list.
   297    297   #
   298    298   # Arguments:
................................................................................
   305    305   
   306    306   proc ::math::stats {val1 val2 args} {
   307    307        set sum [ expr { $val1+$val2 } ]
   308    308        set N [ expr { [ llength $args ] + 2 } ]
   309    309        foreach val $args {
   310    310           set sum [ expr { $sum+$val } ]
   311    311        }
   312         -     set mean [ expr { $sum/$N } ]
          312  +     set mean [ expr { $sum/double($N) } ]
   313    313        set sigma_sq 0
   314    314        foreach val [ concat $val1 $val2 $args ] {
   315    315           set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
   316    316        }
   317         -     set sigma_sq [ expr { $sigma_sq/($N-1) } ] 
          317  +     set sigma_sq [ expr { $sigma_sq/double($N-1) } ]
   318    318        set sigma [ expr { sqrt($sigma_sq) } ]
   319    319        set cov [ expr { ($sigma/$mean)*100 } ]
   320    320        return [ list $mean $sigma $cov ]
   321    321   }
   322    322   
   323    323   # ::math::sum --
   324    324   #