| 1 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 2 | # FILE : tolmethods.tcl |
|---|
| 3 | # PURPOSE : Metodos de Tol desde TCL |
|---|
| 4 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 5 | |
|---|
| 6 | |
|---|
| 7 | # includes. 1 -> Include. 0 -> No |
|---|
| 8 | if { 0 } { |
|---|
| 9 | # packages |
|---|
| 10 | package require Tk |
|---|
| 11 | package require BWidget |
|---|
| 12 | # package require BLT |
|---|
| 13 | # |
|---|
| 14 | wm geometry . 1x1+1+1 |
|---|
| 15 | set toltk_script_path [file dirname [info script]] |
|---|
| 16 | # load tclIndex |
|---|
| 17 | set dir $toltk_script_path |
|---|
| 18 | source [file join $toltk_script_path "tclIndex"] |
|---|
| 19 | unset dir |
|---|
| 20 | if { ![info exists toltk_library] } { |
|---|
| 21 | set toltk_library [file join $toltk_script_path ..] |
|---|
| 22 | } |
|---|
| 23 | # messages |
|---|
| 24 | package require msgcat |
|---|
| 25 | namespace import msgcat::* |
|---|
| 26 | # bitmap |
|---|
| 27 | Bitmap::use |
|---|
| 28 | set toltk_script_path [file dirname [info script]] |
|---|
| 29 | #Tol load images: |
|---|
| 30 | set toltk_images_path [file join ${toltk_script_path} images] |
|---|
| 31 | if { [lsearch $Bitmap::path $toltk_images_path] == -1 } { |
|---|
| 32 | #añade la ruta de las imágenes para que Bitmap sepa donde están: |
|---|
| 33 | lappend Bitmap::path [file join $toltk_script_path images] |
|---|
| 34 | } |
|---|
| 35 | } |
|---|
| 36 | |
|---|
| 37 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 38 | # Methods to Serie |
|---|
| 39 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 40 | |
|---|
| 41 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 42 | proc Tol_SerieChartMethod { sergrp fileDest } { |
|---|
| 43 | # |
|---|
| 44 | # PURPOSE: Hook of Chart method |
|---|
| 45 | # |
|---|
| 46 | # PARAMETERS: |
|---|
| 47 | # sergrp -> group of series |
|---|
| 48 | # fileDest -> destination file |
|---|
| 49 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 50 | # cargamos la variable GCFFile de TOL |
|---|
| 51 | set fileGCF [TclGetVar Text GCFFile] |
|---|
| 52 | if {![file exists $fileGCF]} { |
|---|
| 53 | set fileGCF {} |
|---|
| 54 | } |
|---|
| 55 | # MDI |
|---|
| 56 | set tl [::project::CreateForm \ |
|---|
| 57 | -title [mc "Series graph"] \ |
|---|
| 58 | -type Graphs \ |
|---|
| 59 | -iniconfig SeriesGraph \ |
|---|
| 60 | -width 600 -height 200 |
|---|
| 61 | ] |
|---|
| 62 | set top [$tl getframe] |
|---|
| 63 | |
|---|
| 64 | set isphoto [expr {$fileDest ne ""}] |
|---|
| 65 | #Tolcon_Trace "set isphoto [expr {$fileDest ne {}}]" |
|---|
| 66 | set Instance [::SeriesGraph::Create $top.g $sergrp \ |
|---|
| 67 | -photo $isphoto -fileGCF $fileGCF] |
|---|
| 68 | bind $top.g <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 69 | pack $top.g -fill both -expand yes |
|---|
| 70 | update |
|---|
| 71 | |
|---|
| 72 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 73 | if {$isphoto} { |
|---|
| 74 | ::bayesGraph::TakePhoto $Instance $fileDest |
|---|
| 75 | after idle "destroy $tl" |
|---|
| 76 | } |
|---|
| 77 | } |
|---|
| 78 | |
|---|
| 79 | |
|---|
| 80 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 81 | proc Tol_SerieChart { title source gcfFile geometry filetosave } { |
|---|
| 82 | # |
|---|
| 83 | # PURPOSE: Paint the graph of a set of series |
|---|
| 84 | # |
|---|
| 85 | # PARAMETERS: |
|---|
| 86 | # title -> title for the graph |
|---|
| 87 | # source -> reference to the set |
|---|
| 88 | # gcfFile -> a gcf to aply to the graph |
|---|
| 89 | # geometry -> geometry for the window of the graph |
|---|
| 90 | # filetosave -> if a file name is given the graph is written to disk instead |
|---|
| 91 | # of displayed |
|---|
| 92 | # |
|---|
| 93 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 94 | # GCF |
|---|
| 95 | if {![string length $gcfFile]} { |
|---|
| 96 | set gcfFile [TclGetVar Text GCFFile] |
|---|
| 97 | if {[string length $gcfFile]} { |
|---|
| 98 | eval set gcfFile $gcfFile |
|---|
| 99 | } |
|---|
| 100 | } |
|---|
| 101 | if {![file exists $gcfFile]} { |
|---|
| 102 | set gcfFile {} |
|---|
| 103 | } |
|---|
| 104 | puts "GCF FILE: $gcfFile" |
|---|
| 105 | # Title |
|---|
| 106 | set wTitle $title |
|---|
| 107 | if {![string length $title]} { |
|---|
| 108 | set wTitle [mc "Series graph"] |
|---|
| 109 | } |
|---|
| 110 | |
|---|
| 111 | # Create Group Series |
|---|
| 112 | set nsource [lindex [TclGetVar Set $source] 0] |
|---|
| 113 | set lstSerie {} |
|---|
| 114 | for {set i 1} {$i <= $nsource} {incr i} { |
|---|
| 115 | lappend lstSerie "$source $i" |
|---|
| 116 | } |
|---|
| 117 | set sergrp tableserie[clock clicks] |
|---|
| 118 | set tl "" |
|---|
| 119 | if {[llength $lstSerie]} { |
|---|
| 120 | # MDI |
|---|
| 121 | set tl [::project::CreateForm \ |
|---|
| 122 | -title $wTitle -type Graphs -iniconfig SeriesGraph -geometry $geometry] |
|---|
| 123 | $tl setgeometry $geometry |
|---|
| 124 | set top [$tl getframe] |
|---|
| 125 | eval ::tol::seriegrp create $sergrp $lstSerie |
|---|
| 126 | # Create |
|---|
| 127 | set isphoto [expr {$filetosave ne ""}] |
|---|
| 128 | set Instance [::SeriesGraph::Create $top.g $sergrp \ |
|---|
| 129 | -photo $isphoto -fileGCF $gcfFile -title [list $title]] |
|---|
| 130 | bind $top.g <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 131 | pack $top.g -fill both -expand yes |
|---|
| 132 | update |
|---|
| 133 | # Control Axis |
|---|
| 134 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 135 | # Save graph ? |
|---|
| 136 | if {$isphoto} { |
|---|
| 137 | ::bayesGraph::TakePhoto $Instance $filetosave |
|---|
| 138 | after idle "destroy $tl" |
|---|
| 139 | } |
|---|
| 140 | } else { |
|---|
| 141 | set msg [mc {No selection information related}] |
|---|
| 142 | ::TolConsole::HciWriter "<W>${msg}</W>" |
|---|
| 143 | } |
|---|
| 144 | return $tl |
|---|
| 145 | } |
|---|
| 146 | |
|---|
| 147 | |
|---|
| 148 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 149 | proc Tol_SerieTabulate { source {title ""} {geometry {}} } { |
|---|
| 150 | # |
|---|
| 151 | # PURPOSE: Tabulates a serie in a TolBase table window |
|---|
| 152 | # |
|---|
| 153 | # PARAMETERS: |
|---|
| 154 | # source -> the tol serie variable or variables (if a list is given) |
|---|
| 155 | # geometry -> geometry specification |
|---|
| 156 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 157 | |
|---|
| 158 | # chek type TOL of source |
|---|
| 159 | set gramVar [GetGlobalUniqueName __tabser__] |
|---|
| 160 | ::tol::console eval "Text $gramVar = Grammar($source);" |
|---|
| 161 | set namGra [string trim [TclGetVar Text $gramVar] {"}];#{"} |
|---|
| 162 | # destroy |
|---|
| 163 | ::tol::console stack release $gramVar |
|---|
| 164 | # list of series tabulate |
|---|
| 165 | set lstSerie {} |
|---|
| 166 | switch $namGra { |
|---|
| 167 | Serie { set lstSerie $source } |
|---|
| 168 | Set { |
|---|
| 169 | set nsource [lindex [TclGetVar Set $source] 0] |
|---|
| 170 | for {set i 1} {$i <= $nsource} {incr i} { |
|---|
| 171 | lappend lstSerie "$source $i" |
|---|
| 172 | } |
|---|
| 173 | } |
|---|
| 174 | } |
|---|
| 175 | # lstSerie > 0 ? |
|---|
| 176 | set tl {} |
|---|
| 177 | if {[llength $lstSerie]} { |
|---|
| 178 | # create sergrp |
|---|
| 179 | set sergrp group[clock clicks] |
|---|
| 180 | eval "::tol::seriegrp create $sergrp $lstSerie" |
|---|
| 181 | #title |
|---|
| 182 | if { ![llength $title] } { |
|---|
| 183 | set title [mc "Time series table"] |
|---|
| 184 | } |
|---|
| 185 | # create |
|---|
| 186 | set tl [::project::CreateForm \ |
|---|
| 187 | -title $title \ |
|---|
| 188 | -iniconfig SeriesTable \ |
|---|
| 189 | -type Tables \ |
|---|
| 190 | -geometry $geometry |
|---|
| 191 | ] |
|---|
| 192 | $tl setgeometry $geometry |
|---|
| 193 | set tlf [$tl getframe] |
|---|
| 194 | # configuration |
|---|
| 195 | btable $tlf.t -parent $tl \ |
|---|
| 196 | -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ |
|---|
| 197 | -iniconfig btable |
|---|
| 198 | $tlf.t fillSerie $sergrp |
|---|
| 199 | bind $tlf.t <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 200 | $tl bind <Control-F4> [list $tl kill] |
|---|
| 201 | pack $tlf.t -fill both -expand yes |
|---|
| 202 | update |
|---|
| 203 | } |
|---|
| 204 | return $tl |
|---|
| 205 | } |
|---|
| 206 | |
|---|
| 207 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 208 | proc Tol_SerieAutocor { source {title ""} {geometry {}} } { |
|---|
| 209 | # |
|---|
| 210 | # PURPOSE: Tabulates a serie in a TolBase table window |
|---|
| 211 | # |
|---|
| 212 | # PARAMETERS: |
|---|
| 213 | # source -> the tol serie variable or variables (if a list is given) |
|---|
| 214 | # geometry -> geometry specification |
|---|
| 215 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 216 | |
|---|
| 217 | # name |
|---|
| 218 | if {[llength $source] > 1} { |
|---|
| 219 | set nameSerie [lindex [::tol::info variable $source] 1] |
|---|
| 220 | } else { |
|---|
| 221 | set nameSerie $source |
|---|
| 222 | } |
|---|
| 223 | #title |
|---|
| 224 | if { ![llength $title] } { |
|---|
| 225 | set title "[mc "Autocorrelation graph"]: $nameSerie" |
|---|
| 226 | } |
|---|
| 227 | # create |
|---|
| 228 | set tl [::project::CreateForm \ |
|---|
| 229 | -title $title \ |
|---|
| 230 | -iniconfig AutocorGraph \ |
|---|
| 231 | -type Graphs \ |
|---|
| 232 | -geometry $geometry -helpkey "Tb4GraAco" |
|---|
| 233 | ] |
|---|
| 234 | $tl setgeometry $geometry |
|---|
| 235 | set tlf [$tl getframe] |
|---|
| 236 | # configuration |
|---|
| 237 | ::AutocorGraph::Create $tlf.g $source |
|---|
| 238 | $tl bind <Control-F4> "$tl kill; break" |
|---|
| 239 | pack $tlf.g -fill both -expand yes |
|---|
| 240 | update |
|---|
| 241 | return $tl |
|---|
| 242 | } |
|---|
| 243 | |
|---|
| 244 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 245 | # Methods to Set |
|---|
| 246 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 247 | |
|---|
| 248 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 249 | proc Tol_SetChartMethod { title source gcfFile geometry filetosave lstNames type lstPairs } { |
|---|
| 250 | # |
|---|
| 251 | # PURPOSE: Hook of Chart method |
|---|
| 252 | # |
|---|
| 253 | # PARAMETERS: |
|---|
| 254 | # title -> title for the graph |
|---|
| 255 | # source -> reference to the set |
|---|
| 256 | # gcfFile -> a gcf to aply to the graph |
|---|
| 257 | # geometry -> geometry for the window of the graph |
|---|
| 258 | # file -> if a file name is given the graph is written to disk instead of displayed |
|---|
| 259 | # lstNames -> names for the series/points,.. |
|---|
| 260 | # type -> 0 for custom association of data columns |
|---|
| 261 | # -> 1 for all data columns to first one |
|---|
| 262 | # -> 2 for all data columns to generic |
|---|
| 263 | # -> 3 for even data columns to odd ones |
|---|
| 264 | # lstPairs -> when type is 0 pairs is the list of correspondence beetwen index |
|---|
| 265 | # columns to data columns (x-y pairs) |
|---|
| 266 | # |
|---|
| 267 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 268 | # GCF |
|---|
| 269 | if {![string length $gcfFile]} { |
|---|
| 270 | set gcfFile [TclGetVar Text GCFFile] |
|---|
| 271 | } |
|---|
| 272 | if {![file exists $gcfFile]} { |
|---|
| 273 | set gcfFile {} |
|---|
| 274 | } |
|---|
| 275 | # Title |
|---|
| 276 | set wTitle $title |
|---|
| 277 | if {![string length $title]} { |
|---|
| 278 | set wTitle [mc "Set graph"] |
|---|
| 279 | } |
|---|
| 280 | # MDI |
|---|
| 281 | set tl [::project::CreateForm \ |
|---|
| 282 | -title $wTitle -type Graphs -iniconfig SetGraph -geometry $geometry] |
|---|
| 283 | $tl setgeometry $geometry |
|---|
| 284 | set top [$tl getframe] |
|---|
| 285 | # if source is a list is interpreted as a set name and indexes accesing a element |
|---|
| 286 | if { [llength $source] > 1 } { |
|---|
| 287 | set setname [GetUniqueName Set] |
|---|
| 288 | set sourcename [lindex $source 0] |
|---|
| 289 | set strtoeval "Set ${setname} = ${sourcename}" |
|---|
| 290 | for {set i 1} {$i < [llength $source]} {incr i} { |
|---|
| 291 | set elem [lindex $source $i] |
|---|
| 292 | set strtoeval "${strtoeval}\[$elem\]" |
|---|
| 293 | } |
|---|
| 294 | ::tol::console eval $strtoeval |
|---|
| 295 | set source $setname |
|---|
| 296 | } |
|---|
| 297 | set cmd tableset[clock clicks] |
|---|
| 298 | ::tol::tableset create $cmd $source |
|---|
| 299 | set Instance [::SetGraphDialog::DrawSet $top.g $cmd $source $type $lstPairs \ |
|---|
| 300 | $lstNames $gcfFile [list $title]] |
|---|
| 301 | bind $top.g <Destroy> +[list ::tol::tableset destroy $cmd] |
|---|
| 302 | if { [llength $source] > 1} { |
|---|
| 303 | bind $top.g <Destroy> +[list ::tol::stack release $source] |
|---|
| 304 | } |
|---|
| 305 | pack $top.g -fill both -expand yes |
|---|
| 306 | update |
|---|
| 307 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 308 | if { [string length $filetosave] } { |
|---|
| 309 | ::bayesGraph::TakePhoto $Instance $filetosave |
|---|
| 310 | after idle "destroy $tl" |
|---|
| 311 | } |
|---|
| 312 | return $tl |
|---|
| 313 | } |
|---|
| 314 | |
|---|
| 315 | |
|---|
| 316 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 317 | proc Tol_SetTabulate { set {title ""} {geometry {}} } { |
|---|
| 318 | # |
|---|
| 319 | # PURPOSE: Tabulates a set in a TolBase table window |
|---|
| 320 | # |
|---|
| 321 | # PARAMETERS: |
|---|
| 322 | # source -> the tol set variable |
|---|
| 323 | # geometry -> geometry specification |
|---|
| 324 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 325 | |
|---|
| 326 | if {[llength $set] > 1} { |
|---|
| 327 | set nameSet [lindex [::tol::info variable $set] 1] |
|---|
| 328 | } else { |
|---|
| 329 | set nameSet $set |
|---|
| 330 | } |
|---|
| 331 | |
|---|
| 332 | if { ![llength $title] } { set title "[mc "Set table"]: $nameSet" } |
|---|
| 333 | |
|---|
| 334 | set setgrp group[clock clicks] |
|---|
| 335 | |
|---|
| 336 | set tl {} |
|---|
| 337 | if {![catch {::tol::tableset create $setgrp $set}]} { |
|---|
| 338 | # create |
|---|
| 339 | set tl [::project::CreateForm \ |
|---|
| 340 | -title $title \ |
|---|
| 341 | -iniconfig SetTable \ |
|---|
| 342 | -type Tables \ |
|---|
| 343 | -geometry $geometry |
|---|
| 344 | ] |
|---|
| 345 | $tl setgeometry $geometry |
|---|
| 346 | set tlf [$tl getframe] |
|---|
| 347 | # config |
|---|
| 348 | btable $tlf.t -parent $tl \ |
|---|
| 349 | -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ |
|---|
| 350 | -iniconfig btable |
|---|
| 351 | $tlf.t fillSet $setgrp |
|---|
| 352 | pack $tlf.t -fill both -expand yes |
|---|
| 353 | bind $tlf.t <Destroy> +[list ::tol::tableset destroy $setgrp] |
|---|
| 354 | $tl bind <Control-F4> [list $tl kill] |
|---|
| 355 | update |
|---|
| 356 | } else { |
|---|
| 357 | tk_messageBox -type ok -icon warning -message [mc "Set not tabulable"]\ |
|---|
| 358 | -parent . -title [mc Warning] |
|---|
| 359 | # -parent $w_tabset -title [mc Warning] |
|---|
| 360 | } |
|---|
| 361 | return $tl |
|---|
| 362 | } |
|---|
