Tcl Library Source Code

2014-01-18  Arjen Markus <[email protected]>
	* statistics.tcl: Added stat_kernel.tcl
	* stat_kernel.tcl: Implements a straightforward kernel density estimation procedure
	* statistics.man: Describe the kernel denstity estimation procedure, moved the description of several
	                  tests to the general section
	* statistics.test: Added three tests for the kernel density estimation (note: one result is a bit troublesome)
	* pkgIndex.tcl: Bumped version of statistics package to 0.9

2013-12-20  Arjen Markus <[email protected]>
	* interpolate.tcl: [Ticket 843c2257d2] Added special case for points coincident with the data points
	* interpolate.test: [Ticket 843c2257d2] Added test case for coincident points

2013-12-17  Andreas Kupries  <[email protected]>

This file records outstanding actions for the math module

dd. 18 january 2014, Arjen Markus
test cases for kernel-density:
One test case is troublesome - uniform kernel, checking the total density


dd. 26 october 2005, Arjen Markus

qcomplex.test: extend the tests for cos/sin .. to include
               non-real results.

dd. 28 september 2005, Arjen Markus

optimize.tcl: linear programming algorithm ignores certain
              constraints (of type x > 0). Needs to be
              fixed

dd. 22 june 2004, Arjen Markus

interpolate.man: add examples
interpolate.tcl: more consistency in the calling convention
                 checks on arguments (add tests for them)

    if { $opt(-bandwidth) <= 0.0 } {
        return -code error -errorcode ARG -errorinfo "The bandwidth must be positive: $opt(-bandwidth)"
    }

    if { $opt(-number) <= 0.0 } {
        return -code error -errorcode ARG -errorinfo "The number of bins must be positive: $opt(-number)"
    }

    if { [lindex $opt(-interval) 0] == [lindex $opt(-interval) 1] } {
        return -code error -errorcode ARG -errorinfo "The interval has length zero: $opt(-interval)"
    }

    if { [llength [info proc $opt(-kernel)]] == 0 } {
        return -code error -errorcode ARG -errorinfo "Unknown kernel function: $opt(-kernel)"
    }

    #
    # Construct the weights

            if { $d != {} } {
                lappend weight [expr {$w / $scale}]
            } else {
                lappend weight {}
            }
        }
    } else {
        set weight [lrepeat [llength $data] [expr {1.0/$ndata}]] ;# Note: missing values have weight zero
    }

    #
    # Construct the centres of the bins
    #
    set xbegin [lindex $opt(-interval) 0]
    set xend   [lindex $opt(-interval) 1]
    set dx     [expr {($xend - $xbegin) / double($opt(-number))}]
    set xb     [expr {$xbegin + 0.5 * $dx}]
    set xvalue {}
    for {set i 0} {$i < $opt(-number)} {incr i} {
        lappend xvalue [expr {$xb + $i * $dx}]
    }

    #

# Note:
#    The standard deviation is 1.
#
proc ::math::statistics::gaussian {x} {
    return [expr {exp(-0.5*$x*$x) / sqrt(2.0*acos(-1.0))}]
}
proc ::math::statistics::uniform {x} {
    if { abs($x) <= 1.0 } {
        return 0.5
    } else {
        return 0.0
    }
}
proc ::math::statistics::triangular {x} {
    if { abs($x) < 1.0 } {

} -result -0.175757575758

test "spearman-rank-extended-1.0" "Test extended Spearman rank correlation procedure" -match tolerant -body {
    ::math::statistics::spearman-rank-extended {106  86 100 101  99 103  97 113 112 110} \
                                               {  7   0  27  50  28  29  20  12   6  17}
} -result {-0.175757575758 10 -0.456397284}

#
# Note: for the uniform kernel the sum is roughly 0.92. It would appear from a visual
# investigation that the sides may influence this, as well as the default bandwidth.
# Leave it for now.
#
test "kernel-density-1.0" "Test various kernel functions" -body {
    set data {1 2 3 4 5 6 7 8 9 10}

    set roughlyOne {}

    foreach kernel {gaussian uniform triangular epanechnikov biweight cosine logistic} {
        set result [::math::statistics::kernel-density $data -kernel $kernel]

        set sum 0.0
        set xbegin [lindex $result 2 0]
        set xend   [lindex $result 2 1]
        set number [llength [lindex $result 0]]
        set dx     [expr {($xend-$xbegin) / $number}]

        #
        # Integral should be roughly one
        #
        set sum 0.0
        foreach v [lindex $result 1] {
            set sum [expr {$sum + $dx * $v}]
        }

        lappend roughlyOne [expr {abs($sum-1.0) < 0.01}]
    }

    return $roughlyOne
} -result {1 0 1 1 1 1 1}

test "kernel-density-1.1" "Test various options - just that they have effect" -body {
    set subResults {}

    set data {1 2 3 4 5 6 7 8 9 10}

    set result [::math::statistics::kernel-density $data -number 20]
    lappend subResults [llength [lindex $result 0]]  ;# Number of bins
    lappend subResults [llength [lindex $result 1]]  ;# Number of density values

    set result [::math::statistics::kernel-density $data -interval {0 20}]
    lappend subResults [lindex $result 2 0]          ;# Beginning of interval
    lappend subResults [lindex $result 2 1]          ;# End of interval
    lappend subResults [expr {[lindex $result 0 0]   > [lindex $result 2 0]}] ;# First bin -- beginning of interval
    lappend subResults [expr {[lindex $result 0 0]   < [lindex $result 2 1]}] ;# First bin -- end of interval
    lappend subResults [expr {[lindex $result 0 end] > [lindex $result 2 0]}] ;# Last bin -- beginning of interval
    lappend subResults [expr {[lindex $result 0 end] < [lindex $result 2 1]}] ;# Last bin -- end of interval

    set result [::math::statistics::kernel-density $data -bandwidth 2]
    lappend subResults [lindex $result 2 end]        ;# Bandwidth

    return $subResults
} -result {20 20 0 20 1 1 1 1 2}

test "kernel-density-1.2" "Dealing with missing values" -body {
    set subResults {}

    set data {1 2 3 4 {} 6 7 8 9 10}

    set result [::math::statistics::kernel-density $data]

    set sum 0.0
    set xbegin [lindex $result 2 0]
    set xend   [lindex $result 2 1]
    set number [llength [lindex $result 0]]
    set dx     [expr {($xend-$xbegin) / $number}]

    #
    # Integral should be roughly one
    #
    set sum 0.0
    foreach v [lindex $result 1] {
        set sum [expr {$sum + $dx * $v}]
    }

    return [expr {abs($sum-1.0) < 0.01}]
} -result 1

# End of test cases
testsuiteCleanup