1# montecarlo.tcl -- 2# Utilities for Monte Carlo simulations 3# 4# Copyright (c) 2007 by Arjen Markus <arjenmarkus@users.sourceforge.net> 5# 6# See the file "license.terms" for information on usage and redistribution 7# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8# 9# RCS: @(#) $Id: montecarlo.tcl,v 1.2 2008/01/23 05:35:02 arjenmarkus Exp $ 10#------------------------------------------------------------------------------ 11 12package require Tcl 8.4 13package require simulation::random 14package require math::statistics 15 16# ::simulation::montecarlo -- 17# Create the namespace 18# 19namespace eval ::simulation::montecarlo { 20} 21 22 23# AcceptAll -- 24# Accept any point 25# 26# Arguments: 27# args Coordinates 28# y Y-coordinate 29# 30proc ::simulation::montecarlo::AcceptAll {args} { 31 return 1 32} 33 34 35# integral2D -- 36# Estimate an integral over a two-dimensional domain, using MC 37# 38# Arguments: 39# domain List of minimum x, maximum x, minimum y and maximum y 40# func Function to be integrated 41# args Option-value pairs: 42# -region proc - accept or reject the chosen point 43# -samples n - number of samples to use 44# Result: 45# Estimated value of the integral 46# 47proc ::simulation::montecarlo::integral2D {domain func args} { 48 set option(-region) AcceptAll 49 set option(-samples) 1000 50 51 foreach {key value} $args { 52 if { [string index $key 0] != "-" } { 53 return -code error "Incorrect option: $key - should start with a -" 54 } 55 set option($key) $value 56 } 57 58 set sum 0.0 59 set count 0 60 set accepted 0 61 set maxcount [expr {10*$option(-samples)}] 62 63 foreach {xmin xmax ymin ymax} $domain {break} 64 set area [expr {($xmax-$xmin)*($ymax-$ymin)}] 65 66 while { $accepted < $option(-samples) && $count < $maxcount } { 67 set x [expr {$xmin + ($xmax-$xmin)*rand()}] 68 set y [expr {$ymin + ($ymax-$ymin)*rand()}] 69 70 if { [$option(-region) $x $y] } { 71 set sum [expr {$sum + [$func $x $y]}] 72 incr accepted 73 } 74 incr count 75 } 76 77 # 78 # The ratio accepted/count gives an estimate of the area 79 # over which we just integrated. 80 # 81 return [expr {$accepted*$sum/$count/$count*$area}] 82} 83 84 85# integral3D -- 86# Estimate an integral over a three-dimensional domain, using MC 87# 88# Arguments: 89# domain List of minimum x, maximum x, minimum y and maximum y, 90# minimum z, maximum z 91# func Function to be integrated 92# args Option-value pairs: 93# -region proc - accept or reject the chosen point 94# -samples n - number of samples to use 95# Result: 96# Estimated value of the integral 97# 98proc ::simulation::montecarlo::integral3D {domain func args} { 99 set option(-region) AcceptAll 100 set option(-samples) 1000 101 102 foreach {key value} $args { 103 if { [string index $key 0] != "-" } { 104 return -code error "Incorrect option: $key - should start with a -" 105 } 106 set option($key) $value 107 } 108 109 set sum 0.0 110 set count 0 111 set accepted 0 112 set maxcount [expr {10*$option(-samples)}] 113 114 foreach {xmin xmax ymin ymax zmin zmax} $domain {break} 115 set area [expr {($xmax-$xmin)*($ymax-$ymin)*($zmax-$zmin)}] 116 117 while { $accepted < $option(-samples) && $count < $maxcount } { 118 set x [expr {$xmin + ($xmax-$xmin)*rand()}] 119 set y [expr {$ymin + ($ymax-$ymin)*rand()}] 120 set z [expr {$zmin + ($zmax-$zmin)*rand()}] 121 122 if { [$option(-region) $x $y $z] } { 123 set sum [expr {$sum + [$func $x $y $z]}] 124 incr accepted 125 } 126 incr count 127 } 128 129 # 130 # The ratio accepted/count gives an estimate of the area 131 # over which we just integrated. 132 # 133 return [expr {$accepted*$sum/$count/$count*$area}] 134} 135 136 137# singleExperiment -- 138# Perform a single MC experiment 139# 140# Arguments: 141# args Option-value pairs, predefined options: 142# -init body - code to initialise the experiment 143# -loop body - code to be run for each trial 144# -final body - code to finalise the experiment 145# -trials n - number of trials 146# -reportfile f - channel to report file 147# -verbose yesno - whether to report the details or not 148# -analysis type - type of analysis to perform 149# (standard, none or the name of a procedure) 150# -columns names - list of names of the columns (for printing) 151# All option-value pairs are available via 152# the procedure getOption 153# 154# Result: 155# Whatever was set via [setExpResult] 156# 157proc ::simulation::montecarlo::singleExperiment {args} { 158 variable exp_option 159 variable exp_result 160 variable trial_result 161 variable trial_first 162 163 catch {unset exp_option} 164 set exp_option(-init) {} 165 set exp_option(-loop) {} 166 set exp_option(-final) {} 167 set exp_option(-trials) {} 168 set exp_option(-reportfile) stdout 169 set exp_option(-verbose) 0 170 set exp_option(-analysis) standard 171 set exp_option(-columns) {} 172 173 set exp_result {} 174 set trial_result {} 175 176 # 177 # Sanity check for the options, and store them 178 # 179 foreach {key value} $args { 180 if { [string index $key 0] != "-" } { 181 return -code error "Incorrect option: $key - should start with a -" 182 } 183 set exp_option($key) $value 184 } 185 186 # 187 # Which analysis procedure 188 # 189 switch -- $exp_option(-analysis) { 190 "standard" { set exp_option(-analysis) ::simulation::montecarlo::StandardAnalysis } 191 "none" { set exp_option(-analysis) "" } 192 } 193 194 # 195 # Now construct the temporary procedure that will do the work 196 # 197 proc DoExperiment {} [string map \ 198 [list INIT $exp_option(-init) LOOP $exp_option(-loop) \ 199 FINAL $exp_option(-final) TRIALS $exp_option(-trials) \ 200 VERBOSE $exp_option(-verbose) \ 201 ANALYSIS $exp_option(-analysis)] \ 202 { 203 INIT 204 for { set trial 0 } { $trial < TRIALS } { incr trial } { 205 LOOP 206 if { VERBOSE } { 207 ::simulation::montecarlo::PrintTrialResult $trial 208 } 209 } 210 FINAL 211 ANALYSIS 212 }] 213 # TODO: analysis of all trial results 214 215 # 216 # Do the experiment and remove it. The results 217 # 218 DoExperiment 219 rename DoExperiment {} 220 221 return $exp_result 222} 223 224 225# transposeData -- 226# Transpose a matrix of data 227# 228# Arguments: 229# values List of lists of values 230# 231# Result: 232# Transposed list 233# 234proc ::simulation::montecarlo::transposeData {values} { 235 set transpose {} 236 set c 0 237 foreach col [lindex $values 0] { 238 set newrow {} 239 foreach row $values { 240 lappend newrow [lindex $row $c] 241 } 242 lappend transpose $newrow 243 incr c 244 } 245 return $transpose 246} 247 248 249# setTrialResult -- 250# Set the result of an individual trial 251# 252# Arguments: 253# values List of values to be stored 254# 255# Result: 256# None 257# 258proc ::simulation::montecarlo::setTrialResult {values} { 259 260 lappend ::simulation::montecarlo::trial_result $values 261} 262 263 264# PrintTrialResult -- 265# Print the result of the current trial 266# 267# Arguments: 268# trial Trial number 269# 270# Result: 271# None 272# 273proc ::simulation::montecarlo::PrintTrialResult {trial} { 274 275 set outfile [getOption reportfile] 276 277 # 278 # Print the column names 279 # 280 if { $trial == 0 } { 281 set columns [getOption columns] 282 set format "%5.5s [string repeat %12.12s [llength $columns]]" 283 284 puts $outfile [eval format [list $format] [list " "] $columns] 285 } 286 287 # 288 # Print the results 289 # 290 set result [lindex $::simulation::montecarlo::trial_result end] 291 292 set format "%5d:[string repeat %12g [llength $result]]" 293 294 puts $outfile [eval format $format $trial $result] 295} 296 297 298# setExpResult -- 299# Set the result for the complete experiment 300# 301# Arguments: 302# values List of values to be stored 303# 304# Result: 305# None 306# 307proc ::simulation::montecarlo::setExpResult {values} { 308 309 set ::simulation::montecarlo::exp_result $values 310} 311 312 313# getExpResult -- 314# Return the result of the complete experiment 315# 316# Arguments: 317# None 318# Result: 319# Whatever was set via setExpResult 320# 321proc ::simulation::montecarlo::getExpResult {} { 322 323 return $::simulation::montecarlo::exp_result 324} 325 326 327# getTrialResults -- 328# Return the list of individual results for all trials 329# 330# Arguments: 331# None 332# Result: 333# Whatever was set via setTrialResult 334# 335proc ::simulation::montecarlo::getTrialResults {} { 336 337 return $::simulation::montecarlo::trial_result 338} 339 340 341# getOption -- 342# Return the value of an option 343# 344# Arguments: 345# option Name of the option (without -) 346# Result: 347# The value or an error message if it does not exist 348# 349proc ::simulation::montecarlo::getOption {option} { 350 variable exp_option 351 352 if { [info exists exp_option(-$option)] } { 353 return $exp_option(-$option) 354 } else { 355 return -code error "No such option: $option" 356 } 357} 358 359 360# hasOption -- 361# Check if the option is available 362# 363# Arguments: 364# option Name of the option (without -) 365# Result: 366# 1 if it is available, 0 if not 367# 368proc ::simulation::montecarlo::hasOption {option} { 369 variable exp_option 370 371 if { [info exists exp_option(-$option)] } { 372 return 1 373 } else { 374 return 0 375 } 376} 377 378 379# StandardAnalysis -- 380# Perform standard analysis on the trial data 381# 382# Arguments: 383# None 384# Result: 385# None 386# Side effects: 387# Prints the results to the result file and stores them as 388# the experiment results. 389# 390proc ::simulation::montecarlo::StandardAnalysis {} { 391 392 set repfile [getOption reportfile] 393 set names [getOption columns] 394 395 set values [transposeData [getTrialResults]] 396 397 set exp_result {} 398 399 # 400 # First part: basic statistics 401 # 402 set part_one {} 403 404 puts $repfile "Basic statistical parameters:" 405 set form "%12.12s[string repeat %12g 4]" 406 puts $repfile [format [string repeat "%12.12s" 5] "" Mean Stdev Min Max] 407 408 foreach row $values name $names { 409 set basicStats [::math::statistics::basic-stats $row] 410 lappend part_one $basicStats 411 412 puts $repfile [format $form $name \ 413 [lindex $basicStats 0] \ 414 [lindex $basicStats 4] \ 415 [lindex $basicStats 1] \ 416 [lindex $basicStats 2]] 417 } 418 419 # 420 # Second part: correlation matrix 421 # 422 set form "%12.12s[string repeat %12g [llength $values]]" 423 424 puts $repfile "Correlation matrix:" 425 puts $repfile [eval format "%12.12s[string repeat %12.12s [llength $values]]" [list ""] $names] 426 427 set part_two {} 428 foreach row $values rowname $names { 429 set line {} 430 431 foreach col $values { 432 set corr [::math::statistics::corr $col $row] 433 lappend line $corr 434 } 435 lappend part_two $line 436 puts $repfile [eval format $form $rowname $line] 437 } 438 439 setExpResult [list $part_one $part_two] 440} 441 442# Announce the package 443# 444package provide simulation::montecarlo 0.1 445 446# main -- 447# Quick test 448# 449if { 0 } { 450proc f {x y} { 451 return $x 452} 453puts "Integral over rectangle: [::simulation::montecarlo::integral2D {0 1 0 1} f]" 454puts [time { 455set a [::simulation::montecarlo::integral2D {0 1 0 1} f] 456} 100] 457 458# 459# MC experiments: 460# Determine the mean and median of a set of points and compare them 461# 462::simulation::montecarlo::singleExperiment -init { 463 package require math::statistics 464 465 set prng [::simulation::random::prng_Normal 0.0 1.0] 466} -loop { 467 set numbers {} 468 for { set i 0 } { $i < [getOption samples] } { incr i } { 469 lappend numbers [$prng] 470 } 471 set mean [::math::statistics::mean $numbers] 472 set median [::math::statistics::median $numbers] ;# ? Exists? 473 setTrialResult [list $mean $median] 474} -final { 475 set result [getTrialResults] 476 set means {} 477 set medians {} 478 foreach r $result { 479 foreach {m M} $r break 480 lappend means $m 481 lappend medians $M 482 } 483 puts [getOption reportfile] "Correlation: [::math::statistics::corr $means $medians]" 484 485} -trials 100 -samples 10 -verbose 1 -columns {Mean Median} 486} 487