[Arvore-commits] r2 - in pkg: . R icons man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Aug 8 06:36:01 CEST 2008
Author: isix
Date: 2008-08-08 06:36:00 +0200 (Fri, 08 Aug 2008)
New Revision: 2
Added:
pkg/DESCRIPTION
pkg/R/OnCE.Graph.summary.simwindow.R
pkg/R/String2Numeric.R
pkg/R/aceptability.sim.window.R
pkg/R/acewindow.R
pkg/R/add.node.R
pkg/R/addnodewindows.R
pkg/R/arvore.R
pkg/R/atualiza.grafico.R
pkg/R/carregaTclpath.R
pkg/R/changedofunction.R
pkg/R/clearTreeTkArvore.R
pkg/R/convert2matrix.R
pkg/R/cost.effectiveness.table.R
pkg/R/destinynodewindows.R
pkg/R/dialog.simulation.window.R
pkg/R/dialog.variable.window.R
pkg/R/dimensoes.janela.R
pkg/R/displayInTable.R
pkg/R/exec.text.R
pkg/R/export.global.R
pkg/R/export.tree.graph.R
pkg/R/icer.sim.window.R
pkg/R/inb.sim.window.R
pkg/R/inbwindow.R
pkg/R/load.file.arv.R
pkg/R/markov.coort.table.R
pkg/R/markov.nodes.properties.R
pkg/R/naoimplementado.R
pkg/R/new.file.bot.R
pkg/R/new.tree.R
pkg/R/new.variable.list.R
pkg/R/nodenamewindows.R
pkg/R/nodoselecionado.R
pkg/R/notesnodewindows.R
pkg/R/onGraph.summary.simwindow.R
pkg/R/planoacewindow.R
pkg/R/plot.tree.R
pkg/R/posiciona.janela.centro.R
pkg/R/posiciona.janela.no.mouse.R
pkg/R/posiciona.janela.tela.R
pkg/R/probString2Numeric.R
pkg/R/probability.check.R
pkg/R/probwindows.R
pkg/R/properties.tree.R
pkg/R/refreshF5.R
pkg/R/remove.node.R
pkg/R/removenodewindows.R
pkg/R/rollback.R
pkg/R/safedofunction.R
pkg/R/sair.R
pkg/R/save.as.file.arv.R
pkg/R/save.file.arv.R
pkg/R/select.markov.propertiesMAT.R
pkg/R/select.origins.R
pkg/R/select.subtree.R
pkg/R/set.markov.nodes.properties.R
pkg/R/set.model.type.R
pkg/R/set.value.R
pkg/R/set.zoom.image.tree.R
pkg/R/setaddnode.R
pkg/R/setdestinynode.R
pkg/R/seteffectiveness.R
pkg/R/setnodename.R
pkg/R/setnotesnode.R
pkg/R/setprob.R
pkg/R/setremovenode.R
pkg/R/settreevartype.R
pkg/R/settypenode.R
pkg/R/setutility.R
pkg/R/setvariablelist.R
pkg/R/show.prob.check.window.R
pkg/R/show.summary.rollback.window.R
pkg/R/show.summary.tree.window.R
pkg/R/simple.markov.coort.table.R
pkg/R/sobre.R
pkg/R/splashscreenArvoRe.R
pkg/R/summary.rollback.table.R
pkg/R/summary.simulation.window.R
pkg/R/terminal.markov.coort.table.R
pkg/R/theTreeTkArvore.R
pkg/R/typenodewindows.R
pkg/R/utilitywindows.R
pkg/R/windowresolution.R
pkg/R/zoom.in.but.R
pkg/R/zoom.out.but.R
pkg/icons/
pkg/icons/Arvore.png
pkg/icons/ArvoreIco.png
pkg/icons/Ball.png
pkg/icons/C.png
pkg/icons/Conf.png
pkg/icons/Copy.png
pkg/icons/Cut.png
pkg/icons/D.png
pkg/icons/Display.png
pkg/icons/Display_add.png
pkg/icons/Display_delete.png
pkg/icons/Exit.png
pkg/icons/Export.png
pkg/icons/Graph.png
pkg/icons/Graph2.png
pkg/icons/GraphBar.png
pkg/icons/GraphLine.png
pkg/icons/Icon.bmp
pkg/icons/L.png
pkg/icons/M.png
pkg/icons/Markov.png
pkg/icons/New.png
pkg/icons/Node.png
pkg/icons/Open.png
pkg/icons/Paste.png
pkg/icons/Printer.png
pkg/icons/Redo.png
pkg/icons/Redraw.png
pkg/icons/Run.png
pkg/icons/Save.png
pkg/icons/SaveAs.png
pkg/icons/Settings.png
pkg/icons/Simulation.png
pkg/icons/T.png
pkg/icons/Undo.png
pkg/icons/Variable.png
pkg/icons/World.png
pkg/icons/X.png
pkg/icons/ZoomMinus.png
pkg/icons/ZoomPlus.png
pkg/man/ArvoRe-package.Rd
pkg/man/String2Numeric.Rd
pkg/man/aceptability.sim.window.Rd
pkg/man/acewindow.Rd
pkg/man/add.node.Rd
pkg/man/addnodewindows.Rd
pkg/man/arvore.Rd
pkg/man/atualiza.grafico.Rd
pkg/man/carregaTclpath.Rd
pkg/man/changedofunction.Rd
pkg/man/clearTreeTkArvore.Rd
pkg/man/convert2matrix.Rd
pkg/man/cost.effectiveness.table.Rd
pkg/man/destinynodewindows.Rd
pkg/man/dialog.simulation.window.Rd
pkg/man/dialog.variable.window.Rd
pkg/man/dimensoes.janela.Rd
pkg/man/displayInTable.Rd
pkg/man/exec.text.Rd
pkg/man/export.global.Rd
pkg/man/export.tree.graph.Rd
pkg/man/icer.sim.window.Rd
pkg/man/inb.sim.window.Rd
pkg/man/inbwindow.Rd
pkg/man/load.file.arv.Rd
pkg/man/markov.coort.table.Rd
pkg/man/markov.nodes.properties.Rd
pkg/man/naoimplementado.Rd
pkg/man/new.file.bot.Rd
pkg/man/new.tree.Rd
pkg/man/new.variable.list.Rd
pkg/man/nodenamewindows.Rd
pkg/man/nodoselecionado.Rd
pkg/man/notesnodewindows.Rd
pkg/man/planoacewindow.Rd
pkg/man/plot.tree.Rd
pkg/man/posiciona.janela.centro.Rd
pkg/man/posiciona.janela.no.mouse.Rd
pkg/man/posiciona.janela.tela.Rd
pkg/man/probString2Numeric.Rd
pkg/man/probability.check.Rd
pkg/man/probwindows.Rd
pkg/man/properties.tree.Rd
pkg/man/refreshF5.Rd
pkg/man/remove.node.Rd
pkg/man/removenodewindows.Rd
pkg/man/rollback.Rd
pkg/man/safedofunction.Rd
pkg/man/sair.Rd
pkg/man/save.as.file.arv.Rd
pkg/man/save.file.arv.Rd
pkg/man/select.markov.propertiesMAT.Rd
pkg/man/select.origins.Rd
pkg/man/select.subtree.Rd
pkg/man/set.markov.nodes.properties.Rd
pkg/man/set.model.type.Rd
pkg/man/set.value.Rd
pkg/man/set.zoom.image.tree.Rd
pkg/man/setaddnode.Rd
pkg/man/setdestinynode.Rd
pkg/man/seteffectiveness.Rd
pkg/man/setnodename.Rd
pkg/man/setnotesnode.Rd
pkg/man/setprob.Rd
pkg/man/setremovenode.Rd
pkg/man/settreevartype.Rd
pkg/man/settypenode.Rd
pkg/man/setutility.Rd
pkg/man/setvariablelist.Rd
pkg/man/show.prob.check.window.Rd
pkg/man/show.summary.rollback.window.Rd
pkg/man/show.summary.tree.window.Rd
pkg/man/simple.markov.coort.table.Rd
pkg/man/sobre.Rd
pkg/man/splashscreenArvoRe.Rd
pkg/man/summary.rollback.table.Rd
pkg/man/summary.simulation.window.Rd
pkg/man/terminal.markov.coort.table.Rd
pkg/man/theTreeTkArvore.Rd
pkg/man/typenodewindows.Rd
pkg/man/utilitywindows.Rd
pkg/man/zoom.in.but.Rd
pkg/man/zoom.out.but.Rd
Log:
Added: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION (rev 0)
+++ pkg/DESCRIPTION 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+Package: ArvoRe
+Type: Package
+Title: ArvoRe
+Version: 0.1.6
+Date: 2008-06-24
+Author: Isaias V. Prestes <isaias.prestes at ufrgs.br> and Suzi A. Camey <camey at ufrgs.br>
+Maintainer: Isaias V. Prestes <isaias.prestes at gmail.com>
+Depends: R (>= 2.6.0), tcltk, abind, grid, gplots
+Description: A platform-independent Cost-Effectiveness package for R,
+ using a GUI (graphical user interface) based on the tcltk
+ package.
+License: GPL (>= 2)
+URL: http://www.r-project.org,
+ http://www.mat.ufrgs.br/~camey/ArvoRe/
\ No newline at end of file
Added: pkg/R/OnCE.Graph.summary.simwindow.R
===================================================================
--- pkg/R/OnCE.Graph.summary.simwindow.R (rev 0)
+++ pkg/R/OnCE.Graph.summary.simwindow.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,326 @@
+# FUNCTION :: OnCE.Graph.summary.simwindow # Criada em June 25, 2008 07:01:38 AM
+# Use this function to do something.
+#
+#
+# Revision : Xxxxxxxx - Comentários.sobre.esta.revisão
+#
+#
+# Parameters
+# Alltreatmentstable : summary of simulation dataframe.
+
+# Esta função faz alguma coisa
+
+OnCE.Graph.summary.simwindow <- function(Alltreatmentstable) {
+ CEGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Gráficos"
+ tkwm.title(CEGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(CEGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(CEGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 480
+ g.imgWidth <- 640
+
+ # Canvas window configurations
+ C.Height <- g.imgHeight
+ C.Width <- g.imgWidth
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # The data to plot
+ AllTreatCost <- Alltreatmentstable[Alltreatmentstable$Data == "Cost",]
+ AllTreatEffectiveness <- Alltreatmentstable[Alltreatmentstable$Data == "Effectiveness",]
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(AllTreatCost$Treatment)
+ # The treatments names
+ treatments.label.plot <- AllTreatCost$Treatment
+
+ # What plot?
+ plot.it.to.image <- function(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+# plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+# col = treatments.colors.plot, pch = "*", main = Graphtitle,
+# xlab = xlabel, ylab = ylabel)
+# smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+# legend = c(treatments.label.plot), #legend parameters
+# fill=c(treatments.colors.plot), #legend parameters
+# bg = "gray")
+ plot(c(0,AllTreatEffectiveness$Mean), c(0,AllTreatCost$Mean),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness$Mean)) {
+ lines(c(0,AllTreatEffectiveness$Mean[i]),c(0,AllTreatCost$Mean[i]),
+ col = treatments.colors.plot[i], lty = 2)
+ }
+ smartlegend( x="right", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+# plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+# col = treatments.colors.plot, pch = "*", main = Graphtitle,
+# xlab = xlabel, ylab = ylabel)
+#
+# smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+# legend = c(treatments.label.plot), #legend parameters
+# fill=c(treatments.colors.plot), #legend parameters
+# bg = "gray")
+ plot(c(0,AllTreatEffectiveness$Mean), c(0,AllTreatCost$Mean),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness$Mean)) {
+ lines(c(0,AllTreatEffectiveness$Mean[i]),c(0,AllTreatCost$Mean[i]),
+ col = treatments.colors.plot[i], lty = 2)
+ }
+ smartlegend( x="right", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+# plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+# col = treatments.colors.plot, pch = "*", main = Graphtitle,
+# xlab = xlabel, ylab = ylabel)
+#
+# smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+# legend = c(treatments.label.plot), #legend parameters
+# fill=c(treatments.colors.plot), #legend parameters
+# bg = "gray")
+ plot(c(0,AllTreatEffectiveness$Mean), c(0,AllTreatCost$Mean),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness$Mean)) {
+ lines(c(0,AllTreatEffectiveness$Mean[i]),c(0,AllTreatCost$Mean[i]),
+ col = treatments.colors.plot[i], lty = 2)
+ }
+ smartlegend( x="right", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+
+ dev.off()
+ }
+ }
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(CEGraphWindow)
+ tkwm.deiconify(graphsimulationWindow)
+ tkfocus(graphsimulationWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+# tkconfigure(Export.but, state = "disabled")
+
+ tkbind(CEGraphWindow, "<Return>", OnOK)
+ tkbind(CEGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+
+}
Property changes on: pkg/R/OnCE.Graph.summary.simwindow.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/String2Numeric.R
===================================================================
--- pkg/R/String2Numeric.R (rev 0)
+++ pkg/R/String2Numeric.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`String2Numeric` <-
+function(s) {
+ ans <- exec.text(s)
+ return(ans)
+}
+
Property changes on: pkg/R/String2Numeric.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/aceptability.sim.window.R
===================================================================
--- pkg/R/aceptability.sim.window.R (rev 0)
+++ pkg/R/aceptability.sim.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,484 @@
+`aceptability.sim.window` <-
+function(Alltreatmentstable) {
+ require(abind)
+
+ ACsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Curva de Aceitabilidade (INB)"
+ tkwm.title(ACsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(ACsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # The WTP ---------------------------------------------------------------------
+ WTPL1var <- tclVar(0.1)
+ WTPL2var <- tclVar(10000)
+ WTPpointsvar <- tclVar(10)
+ PoinsOriginal <- 10
+
+ WTPL1Value <- tkentry(Frame1,width="20",textvariable=WTPL1var)
+ tkgrid(tklabel(Frame1,text="Valor mínimo do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPL1Value, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ WTPL2Value <- tkentry(Frame1,width="20",textvariable=WTPL2var)
+ tkgrid(tklabel(Frame1,text="Valor máximo do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPL2Value, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ ### Numeric format settings ###
+ numericSpinBox <- tkwidget(Frame1, "SpinBox", editable=FALSE, range = c(0,100,1), width = 3)
+ labeldigits <- tklabel(Frame1,text="Número de intervalos:")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", PoinsOriginal,sep = ""))
+
+
+ # Monta os frames
+ tkgrid(Frame1, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(Frame2, sticky = "s", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+ WTPL1Val <- as.numeric(tclvalue(WTPL1var))
+ WTPL2Val <- as.numeric(tclvalue(WTPL2var))
+ WTPPoints <- as.integer(tclvalue(tcl(numericSpinBox,"getvalue")))
+
+ WTP <- seq(WTPL1Val, WTPL2Val, (WTPL2Val-WTPL1Val)/WTPPoints )
+
+ WTPVal <- 0.1
+
+ if ( WTPL1Val < WTPL2Val ) {
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+ ans <- data.frame( Standart = rep(0,length(WTP)))
+ names.ans <- c("Padrão")
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ inb <- (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1]) *
+ WTP - (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1])
+ var.inb <- ( WTP^2
+ ) * Data.alternative.Effectiveness$Variance[i] +
+ Data.alternative.Cost$Variance[i] -
+ 2 * WTP * ( Data.alternative.Cost$CovDcDe[i] )
+ inb.stat.test <- inb/var.inb^0.5
+ Strategy <- Data.alternative.Cost$Treatment[i]
+ p.val.inb <- pnorm(inb.stat.test)
+
+ ans.line <- data.frame( p.val.inb )
+ names.ans <- c(names.ans, Strategy)
+ ans <- abind(ans, ans.line, along = 2)
+
+ }
+ ans <- as.data.frame(ans)
+ names(ans) <- names.ans
+# print(ans)
+
+ OnAC <- function(WTP, ACProbabilities) {
+ ACGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Gráficos"
+ tkwm.title(ACGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(ACGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(ACGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 480
+ g.imgWidth <- 640
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(names(ACProbabilities))
+ # The treatments names
+ treatments.label.plot <- names(ACProbabilities)
+
+ # What plot?
+ plot.it.to.image <- function(ACProbabilities, WTP, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+ smartlegend( x="right", y= "top", inset=0,
+ legend = c(treatments.label.plot),
+ fill=c(treatments.colors.plot),
+ bg = "gray")
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+ smartlegend( x="right", y= "top", inset=0,
+ legend = c(treatments.label.plot),
+ fill=c(treatments.colors.plot),
+ bg = "gray")
+
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+ smartlegend( x="right", y= "top", inset=0,
+ legend = c(treatments.label.plot),
+ fill=c(treatments.colors.plot),
+ bg = "gray")
+
+ dev.off()
+ }
+ }
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(ACGraphWindow)
+ tkwm.deiconify(ACsimtableWindow)
+ tkfocus(ACsimtableWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+ # posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ # tkconfigure(Export.but, state = "disabled")
+
+ tkbind(ACGraphWindow, "<Return>", OnOK)
+ tkbind(ACGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+
+ }
+
+ OnAC(WTP, ans)
+
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(ACsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(Frame2,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(Frame2,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(ACsimtableWindow, "<Return>",OnOK)
+ tkbind(ACsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(ACsimtableWindow, 310, 310)
+
+ tkfocus(ACsimtableWindow)
+
+}
+
Property changes on: pkg/R/aceptability.sim.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/acewindow.R
===================================================================
--- pkg/R/acewindow.R (rev 0)
+++ pkg/R/acewindow.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,129 @@
+`acewindow` <-
+function(TheTree) {
+ require(abind)
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione o nodo de tipo 'Decisão' da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ if (( column != 1) && (node.number != 1)) {
+ msg <- paste("A tabela apresentada a seguir exibe resultados apenas para o nodo raiz.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+
+ CEtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(CEtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(CEtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ # Cria os elementos da lista
+ elementos <- Data.CEA$Node.name
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # Monta os frames
+ tkgrid(Frame1, Frame2, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = NA,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff. = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+
+ names(ans) <- c("Procedimento", "Custo médio", "Custo adicional", "Efetividade média",
+ "Efetividade adicional", "Razão C-E", "ICER")
+
+ displayInTable(as.matrix(ans), title="Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(CEtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(CEtableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(CEtableWindow,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(CEtableWindow, "<Return>",OnOK)
+ tkbind(CEtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(CEtableWindow, 300, 180)
+
+ tkfocus(CEtableWindow)
+ }
+}
+
Property changes on: pkg/R/acewindow.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/add.node.R
===================================================================
--- pkg/R/add.node.R (rev 0)
+++ pkg/R/add.node.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,78 @@
+`add.node` <-
+function(TheTree, node.col, node.number, node.name, node.prob, node.type = "C",
+ node.notes = " ", node.destiny = " ", node.utility = 0, node.effectiveness = 0,
+ playnumb = 2) {
+ require(abind)
+
+ variables <- names(TheTree)
+
+ num.col <- dim(TheTree)[2]
+ num.lin <- dim(TheTree)[1]
+
+ Levelmax <- max(TheTree$Level)
+ new.node.level <- node.col + 1
+
+ Data.father <- subset(TheTree, Level == node.col, select = variables)
+ Data.father <- subset(Data.father, Node.N == node.number, select = variables)
+ father.name <- Data.father$Node.name[1]
+
+ if(new.node.level <= Levelmax) {
+ Data <- subset(TheTree, Level == new.node.level, select = variables)
+ new.node.number <- max(Data$Node.N) + 1
+ } else {
+ new.node.number <- 1
+ }
+
+ Payoffs <- matrix(c(0,1), 1, playnumb)
+
+ colnames(Payoffs) <- paste("Payoff",1:length(Payoffs),sep="")
+
+ ans <- data.frame( Level = new.node.level, Node.N = new.node.number, Node.name = node.name,
+ Father = node.number, Father.Name = father.name,
+ Prob = node.prob, Type = node.type, Note = node.notes, Destiny = node.destiny,
+ Payoff1 = node.utility, Payoff2 = node.effectiveness)
+ ans <- abind(TheTree, ans, along=1)
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) < as.numeric(ans$Node.N[i-1]) ) &&
+ ( as.numeric(ans$Level[i]) == as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i-1]
+ ans$Node.N[i-1] <- ans$Node.N[i]
+ ans$Node.N[i] <- old.value
+ usedlevel <- ans$Level[i-1] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- old.value
+ ans$Father.Name[position] <- ans$Node.name[i-1]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+
+ rownames(ans) <- NULL
+ return(ans)
+}
+
Property changes on: pkg/R/add.node.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/addnodewindows.R
===================================================================
--- pkg/R/addnodewindows.R (rev 0)
+++ pkg/R/addnodewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,103 @@
+`addnodewindows` <-
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ node.col <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ if (node.type == "T") {
+ msg <- paste(" O nodo selecionado é de tipo 'Terminal'.\n Altere o tipo do nodo e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ # A janela Tk
+ addnodeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Novo Nodo"
+ tkwm.title(addnodeWindow,title)
+
+ NomeVar <- tclVar("Novo Nodo")
+ NomeEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=NomeVar)
+ tkgrid(tklabel(addnodeWindow,text="Nome do nodo"))
+ tkgrid(NomeEntryWidget)
+
+ ProbabilidadeVar <- tclVar("0.0")
+ ProbabilityEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=ProbabilidadeVar)
+ tkgrid(tklabel(addnodeWindow,text="Probabilidade"))
+ tkgrid(ProbabilityEntryWidget)
+
+ UtilidadeVar <- tclVar("0.0")
+ UtilityEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=UtilidadeVar)
+ tkgrid(tklabel(addnodeWindow,text="Custo / Payoff"))
+ tkgrid(UtilityEntryWidget)
+
+ EffectivenessVar <- tclVar("0.0")
+ EffectivenessEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=EffectivenessVar)
+ tkgrid(tklabel(addnodeWindow,text="Efetividade / Payoff"))
+ tkgrid(EffectivenessEntryWidget)
+
+ NotasVar <- tclVar(" ")
+ NotesEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=NotasVar)
+ tkgrid(tklabel(addnodeWindow,text="Notas"))
+ tkgrid(NotesEntryWidget)
+
+ tkfocus(addnodeWindow)
+
+ OnOK <- function()
+ {
+ NameVal <- tclvalue(NomeVar)
+ ProbabilidadeVal <- as.numeric( tclvalue(ProbabilidadeVar) )
+ UtilidadeVal <- as.numeric( tclvalue(UtilidadeVar) )
+ EffectivenessVal <- as.numeric( tclvalue(EffectivenessVar) )
+ NotasVal <- tclvalue(NotasVar)
+
+ if ( (ProbabilidadeVal < 0) || (ProbabilidadeVal > 1) ) {
+ msg <- paste("Este não é um valor de probabilidade válido '",ProbVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(addnodeWindow)
+ } else {
+ NewTree <- add.node(TheTree,
+ node.col = node.col,
+ node.number = node.number,
+ node.name = NameVal,
+ node.prob = ProbabilidadeVal,
+ node.type = "C",
+ node.notes = NotasVal,
+ node.destiny = " ",
+ node.utility = UtilidadeVal,
+ node.effectiveness = EffectivenessVal)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setaddnode(NewTree, .EnvironmentArvoRe)
+ refreshF5()
+ tkdestroy(addnodeWindow)
+ tkfocus(tt)
+ }
+
+ }
+ OK.but <-tkbutton(addnodeWindow,text=" OK ",command=OnOK)
+ tkbind(NomeEntryWidget, "<Return>",OnOK)
+ tkbind(ProbabilidadeVar, "<Return>",OnOK)
+ tkbind(UtilityEntryWidget, "<Return>",OnOK)
+ tkbind(EffectivenessEntryWidget, "<Return>",OnOK)
+ tkbind(NotasVar, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(addnodeWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(addnodeWindow,text=" Cancelar ",command=OnCancel)
+ tkbind(addnodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(addnodeWindow, 250, 230)
+ }
+ }
+}
+
Property changes on: pkg/R/addnodewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/arvore.R
===================================================================
--- pkg/R/arvore.R (rev 0)
+++ pkg/R/arvore.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,520 @@
+`arvore` <-
+function(...) {
+ # Se .ArvoReRunning existe, então o ÁrvoRe já está em execução...
+ if (!exists(".ArvoReRunning", envir = globalenv() )) {
+ # ArvoRe Settings
+ library(tcltk)
+ ###############################################################################
+ # THE GAME!!
+ ###############################################################################
+ # Configuration variables
+ .EnvironmentArvoRe <- globalenv()
+ .EnvironmentArvore.Secure <- new.env(parent = globalenv())
+ .arvore.version <- "Alfa-0.1.4" # The ArvoRe version
+ .arvore.release.date <- "June 18, 2008 06:43:29 PM " # The ArvoRe version date
+ .modeltypeArvore <- "CE" # Default calculation method "Simple" # "CEA"
+ .workstatus <- "saved" # File status
+ .opennedfile <- "newfile" # File name
+ .digits <- 3 # Decimal places
+ .init.objects <- objects(all.names = TRUE,
+ envir = .EnvironmentArvoRe) # Objetos existentes antes de abrir o ArvoRe
+ .treeangle <- "squared" # Tipo de ângulos exibidos para a árvore
+ .notesconf <- 0 # Mostrar notas no gráfico { 1 = yes, 0 = no }
+ .probabilityconf <- 1 # Mostrar probabilidades no gráfico { 1 = yes, 0 = no }
+ .payoffsconf <- 1 # Mostrar payoffs no gráfico { 1 = yes, 0 = no }
+ .node.name.font.size <- 12 # Tamanho da fonte para o nome do nodo exibido no gráfico.
+ .payoffs.font.size <- 8 # Tamanho da fonte para payoffs do nodo exibido no gráfico.
+ .notes.font.size <- 6 # Tamanho da fonte para comentários do nodo exibido no gráfico.
+ .absorventstateconf <- 1 # Estados absorventes da cadeia de Markov são interpretados como MORTE.
+
+ assign(".EnvironmentArvoRe", .EnvironmentArvoRe, env = .GlobalEnv)
+ assign(".EnvironmentArvore.Secure", .EnvironmentArvore.Secure, env = .GlobalEnv)
+ assign(".arvore.version", .arvore.version, env = .GlobalEnv)
+ assign(".modeltypeArvore", .modeltypeArvore, env = .GlobalEnv)
+ assign(".workstatus", .workstatus, env = .GlobalEnv)
+ assign(".opennedfile", .opennedfile, env = .GlobalEnv)
+ assign(".digits", .digits, env = .GlobalEnv)
+ assign(".init.objects", .init.objects, env = .GlobalEnv)
+ assign(".treeangle", .treeangle, env = .GlobalEnv)
+ assign(".notesconf", .notesconf, env = .GlobalEnv)
+ assign(".probabilityconf", .probabilityconf, env = .GlobalEnv)
+ assign(".payoffsconf", .payoffsconf, env = .GlobalEnv)
+ assign(".node.name.font.size", .node.name.font.size, env = .GlobalEnv)
+ assign(".node.name.font.size", .node.name.font.size, env = .GlobalEnv)
+ assign(".payoffs.font.size", .payoffs.font.size, env = .GlobalEnv)
+ assign(".notes.font.size", .notes.font.size, env = .GlobalEnv)
+ assign(".absorventstateconf", .absorventstateconf, env = .GlobalEnv)
+# assign("", x, env = .GlobalEnv)
+
+ ###############################################################################
+ # The Tk things
+ ###############################################################################
+ carregaTclpath() # Carrega extensões da Tcltk
+ tclRequire("Img")
+ tclRequire("BWidget")
+ #----------------------------------------------------------------------
+ # tclRequire("Tk") # Used in TckTk 8.5
+
+ # Create a new decision tree
+ new.tree()
+
+ # Set Running flag to TRUE
+ .ArvoReRunning <- TRUE
+
+ # The splashscreen
+ splashscreenArvoRe()
+
+ # The main window
+ tt <- tktoplevel()
+
+ # Send tt addres to .EnvironmentArvoRe
+ assign("tt", tt, .EnvironmentArvoRe)
+
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ .Frametitle1 <- " Representação Gráfica da Árvore "
+ .Frametitle2 <- paste("ÁrvoRe - versão ", .arvore.version, " | ",
+ " | ", "Rodando no R ", getRversion(), " ",
+ sep="")
+ .Frametitle3 <- " Configuração de Nodo "
+
+ tkwm.title(tt, .Windowtitle)
+
+ # Set max and min size to main ArvoRe window
+ tkwm.minsize(tt,640,480)
+ tkwm.maxsize(tt,1024,768)
+
+ # The Frames
+ frameOverall <- tkframe(tt)
+ frameBottons <- tkframe(frameOverall,relief="groove",borderwidth=2)
+ frameUpper <- tkframe(frameOverall,relief="groove",borderwidth=2)
+
+ frameUpperLeft <- tkframe(frameUpper,relief="groove",borderwidth=2)
+
+ frameUpperLeftUp <- tkframe(frameUpperLeft,relief="groove",borderwidth=2)
+ frameUpperLeftDown <- tkframe(frameUpperLeft,relief="groove",borderwidth=2)
+
+ frameUpperRigth <- tkframe(frameUpper,relief="groove",borderwidth=2)
+ tkpack(tklabel(frameUpperRigth,text = .Frametitle1))
+
+ frameLower <- tkframe(frameOverall,relief="sunken",borderwidth=2)
+ tkpack(tklabel(frameLower,text = .Frametitle2, justify = "left"), fill = "x", expand = 0, side = "left")
+
+ tkpack(frameBottons, anchor = "nw", expand = 0, side = "top")#, fill = "x")
+ tkpack(frameUpperLeft, frameUpperRigth, side = "left", expand = 1, fill = "both")
+ tkpack(frameUpper, anchor = "n", side = "top", expand = 1, fill = "both")
+ tkpack(tklabel(frameOverall,text=" "))
+ tkpack(frameLower, anchor = "sw", fill = "x", expand = 0, side = "bottom")
+ tkpack(tklabel(frameOverall,text=" "))
+ tkpack(frameOverall, anchor = "center", expand = 1, fill = "both")
+
+ # The Menu
+ topMenu <- tkmenu(tt)
+ tkconfigure(tt,menu=topMenu)
+ fileMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(fileMenu,"command",label="Novo Ctrl+N",command=function() new.file.bot())
+ tkadd(fileMenu,"command",label="Abrir... Ctrl+O",command=function() load.file.arv())
+ tkadd(fileMenu,"command",label="Salvar Ctrl+S",command=function() save.file.arv())
+ tkadd(fileMenu,"command",label="Salvar como... Ctrl+Alt+S",command=function() save.as.file.arv())
+ tkadd(fileMenu,"separator")
+ tkadd(fileMenu,"command",label="Exportar... Ctrl+E",command=function() export.tree.graph())
+ tkadd(fileMenu,"separator")
+ tkadd(fileMenu,"command",label="Sair Esc",command=function() sair())
+ tkadd(topMenu,"cascade",label="Arquivo",menu=fileMenu)
+
+ editMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(editMenu,"command",label="Desfazer",command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tkadd(editMenu,"command",label="Refazer",command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Recortar",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Copiar",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Colar",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Excluir",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Recortar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Copiar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Colar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Excluir sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Variáveis...",command=function() dialog.variable.window())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Configurações",command=function() properties.tree())
+ tkadd(topMenu,"cascade",label="Editar",menu=editMenu)
+
+ modelMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(modelMenu,"command",label="Árvore de decisão simples",command=function() set.model.type("SD") )
+ tkadd(modelMenu,"separator")
+ tkadd(modelMenu,"command",label="Árvore de decisão Custo-Efetividade",command=function() set.model.type("CE") )
+
+ tkadd(topMenu,"cascade",label="Modelo",menu=modelMenu)
+
+ analysisMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(analysisMenu,"command",label="Valores esperados (Roll Back)",command=function() show.summary.rollback.window())
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Resumo da ACE (ICER)...",command=function() acewindow(TheTree))
+ tkadd(analysisMenu,"command",label="Plano Custo-Efetividade",command=function() planoacewindow(TheTree))
+ tkadd(analysisMenu,"command",label="Rede de Benefício (INB)",command=function() inbwindow(TheTree))
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Resumo da árvore",command=function() show.summary.tree.window())
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Verificar probabilidades",command=function() show.prob.check.window(TheTree))
+ tkadd(topMenu,"cascade",label="Análise",menu=analysisMenu)
+
+ windowMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(windowMenu,"command",label="Zoom +...",command=function() zoom.in.but(imgHeight))
+ tkadd(windowMenu,"command",label="Zoom -...",command=function() zoom.out.but(imgHeight))
+ tkadd(windowMenu,"separator")
+ tkadd(windowMenu,"command",label="Resolução da janela...",command=function() naoimplementado())
+ tkadd(topMenu,"cascade",label="Janela",menu=windowMenu)
+
+ helpMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(helpMenu,"command",label="Ajuda",command=function() help.start())
+ tkadd(helpMenu,"separator")
+ tkadd(helpMenu,"command",label="Sobre o programa",command=function() sobre(.arvore.version, .arvore.release.date))
+ tkadd(topMenu,"cascade",label="Ajuda",menu=helpMenu)
+
+ # The top bottons
+ .Height.but <- 3
+ .Width.but <- 7
+ .Height.img.but <- 32
+ .Width.img.but <- 32
+
+ # New button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/New.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ new.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but,
+ command=function() new.file.bot())
+ tcl("DynamicHelp::add", new.but, "-type", "balloon", "-text", "Novo trabalho")
+
+ } else {
+ new.but <- tkbutton(frameBottons, text="Novo", width=.Width.but, height=.Height.but, command=function() new.file.bot())
+ tcl("DynamicHelp::add", new.but, "-type", "balloon", "-text", "Novo trabalho")
+ }
+ }
+
+ # Open button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Open.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ open.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() load.file.arv())
+ tcl("DynamicHelp::add", open.but, "-type", "balloon", "-text", "Abrir trabalho")
+ } else {
+ open.but <- tkbutton(frameBottons, text="Abrir", width=.Width.img.but, height=.Height.img.but, command=function() load.file.arv())
+ tcl("DynamicHelp::add", open.but, "-type", "balloon", "-text", "Abrir trabalho")
+ }
+ }
+
+ # Save button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Save.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ save.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() save.file.arv())
+ tcl("DynamicHelp::add", save.but, "-type", "balloon", "-text", "Salvar o trabalho atual")
+ } else {
+ save.but <- tkbutton(frameBottons, text="Salvar", width=.Width.img.but, height=.Height.img.but, command=function() save.file.arv())
+ tcl("DynamicHelp::add", save.but, "-type", "balloon", "-text", "Salvar o trabalho atual")
+
+ }
+ }
+
+ # Save As button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/SaveAs.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ saveas.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() save.as.file.arv())
+ tcl("DynamicHelp::add", saveas.but, "-type", "balloon", "-text", "Salvar como...")
+ } else {
+ saveas.but <- tkbutton(frameBottons, text="Salvar \n como...", width=.Width.img.but, height=.Height.img.but, command=function() save.as.file.arv())
+ tcl("DynamicHelp::add", saveas.but, "-type", "balloon", "-text", "Salvar como...")
+ }
+ }
+
+ # Undo button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Undo.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ undo.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", undo.but, "-type", "balloon", "-text", "Desfazer")
+ } else {
+ undo.but <- tkbutton(frameBottons, text="<=", width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", undo.but, "-type", "balloon", "-text", "Desfazer")
+ }
+ }
+
+
+ # Redo button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Redo.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ redo.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", redo.but, "-type", "balloon", "-text", "Refazer")
+ } else {
+ redo.but <- tkbutton(frameBottons, text="=>", width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", redo.but, "-type", "balloon", "-text", "Refazer")
+ }
+ }
+
+ # Markov properties button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Markov.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ markov.prop.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() markov.nodes.properties(TheTree, .EnvironmentArvoRe))
+ tcl("DynamicHelp::add", markov.prop.but, "-type", "balloon", "-text", "Propriedades do estado Markov...")
+ } else {
+ markov.prop.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() markov.nodes.properties(TheTree, .EnvironmentArvoRe))
+ tcl("DynamicHelp::add", markov.prop.but, "-type", "balloon", "-text", "Propriedades do estado Markov...")
+ }
+ }
+
+ # Variable button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Variable.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ variable.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() dialog.variable.window())
+ tcl("DynamicHelp::add", variable.but, "-type", "balloon", "-text", "Variáveis...")
+ } else {
+ variable.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() dialog.variable.window())
+ tcl("DynamicHelp::add", variable.but, "-type", "balloon", "-text", "Variáveis...")
+ }
+ }
+
+ # Simulation button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Simulation.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ simulation.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() dialog.simulation.window())
+ tcl("DynamicHelp::add", simulation.but, "-type", "balloon", "-text", "Simular... (MCMC)")
+ } else {
+ simulation.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() dialog.simulation.window())
+ tcl("DynamicHelp::add", simulation.but, "-type", "balloon", "-text", "Simular... (MCMC)")
+ }
+ }
+
+ # Roll-Back button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Ball.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rollback.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() show.summary.rollback.window())
+ tcl("DynamicHelp::add", rollback.but, "-type", "balloon", "-text", "Roll-back")
+ } else {
+ rollback.but <- tkbutton(frameBottons, text="Roll-Back", width=.Width.img.but, height=.Height.img.but, command=function() show.summary.rollback.window())
+ tcl("DynamicHelp::add", rollback.but, "-type", "balloon", "-text", "Roll-back")
+ }
+ }
+
+ # Sensitivity Analysis button 1-way
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Graph.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ sa.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sa.1way.window())
+ tcl("DynamicHelp::add", sa.but, "-type", "balloon", "-text", "Análise de Sensibilidade 1-way")
+ } else {
+ sa.but <- tkbutton(frameBottons, text="Análise de Sensibilidade 1-way", width=.Width.img.but, height=.Height.img.but, command=function() sa.1way.window())
+ tcl("DynamicHelp::add", sa.but, "-type", "balloon", "-text", "Análise de Sensibilidade 1-way")
+ }
+ }
+
+ # Sensitivity Analysis button 2-way
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Graph2.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ sa2.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sa.2way.window())
+ tcl("DynamicHelp::add", sa2.but, "-type", "balloon", "-text", "Análise de Sensibilidade 2-way")
+ } else {
+ sa2.but <- tkbutton(frameBottons, text="Análise de Sensibilidade 2-way", width=.Width.img.but, height=.Height.img.but, command=function() sa.2way.window())
+ tcl("DynamicHelp::add", sa2.but, "-type", "balloon", "-text", "Análise de Sensibilidade 2-way")
+ }
+ }
+
+ # Zoom In button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/ZoomPlus.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ zoom.in <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() zoom.in.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.in, "-type", "balloon", "-text", "Aumentar zoom")
+ } else {
+ zoom.in <- tkbutton(frameBottons, text="Zoom \n +", width=.Width.img.but, height=.Height.img.but, command=function() zoom.in.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.in, "-type", "balloon", "-text", "Aumentar zoom")
+ }
+ }
+
+
+ # Zoom Out button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/ZoomMinus.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ zoom.out <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() zoom.out.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.out, "-type", "balloon", "-text", "Diminuir zoom")
+ } else {
+ zoom.out <- tkbutton(frameBottons, text="Zoom \n -", width=.Width.img.but, height=.Height.img.but, command=function() zoom.out.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.out, "-type", "balloon", "-text", "Diminuir zoom")
+ }
+ }
+
+
+ # Exit button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Exit.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ exit.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sair())
+ tcl("DynamicHelp::add", exit.but, "-type", "balloon", "-text", "Sair do programa")
+ } else {
+ exit.but <- tkbutton(frameBottons, text="Sair", width=.Width.img.but, height=.Height.img.but, command=function() sair())
+ tcl("DynamicHelp::add", exit.but, "-type", "balloon", "-text", "\"Sair do programa \"")
+ }
+ }
+
+ separator1 <- tklabel(frameBottons, text = " ")
+ separator2 <- tklabel(frameBottons, text = " ")
+ separator3 <- tklabel(frameBottons, text = " ")
+ separator4 <- tklabel(frameBottons, text = " ")
+ separator5 <- tklabel(frameBottons, text = " ")
+ separator6 <- tklabel(frameBottons, text = " ")
+
+ tkgrid(new.but, open.but, save.but, saveas.but, separator1,
+ undo.but, redo.but, separator2,
+ markov.prop.but, variable.but, separator3,
+ simulation.but, rollback.but, separator4,
+ sa.but, sa2.but, separator5,
+ zoom.in, zoom.out, separator6,
+ exit.but,
+ sticky = "nw")
+
+ tkconfigure(new.but, activebackground = "white")
+ tkflash(new.but)
+
+ # The tree structure view
+
+ xScr <- tkscrollbar(frameUpperLeftUp,command=function(...)tkxview(treeWidget,...),orient="horizontal")
+ yScr <- tkscrollbar(frameUpperLeftUp,command=function(...)tkyview(treeWidget,...))
+ treeWidget <- tkwidget(frameUpperLeftUp,"Tree", deltax = 25, deltay = 20,
+ xscrollcommand=function(...)tkset(xScr,...),
+ yscrollcommand=function(...)tkset(yScr,...),
+ width=30,height=15)
+ tkgrid(treeWidget, yScr)
+ tkgrid.configure(treeWidget,stick="nswe")
+ tkgrid.configure(yScr,stick="nsw")
+ tkgrid(xScr)
+ tkgrid.configure(xScr,stick="nswe")
+
+ tkgrid(frameUpperLeftUp, sticky = "nwe")
+
+ # Send treeWidget addres to .EnvironmentArvoRe
+ assign("treeWidget", treeWidget, .EnvironmentArvoRe)
+
+ theTreeTkArvore(TheTree)
+
+ # The Tree Bottons
+ .Height.but <- 2
+ .Width.but <- 16
+
+ node.name.but <- tkbutton(frameUpperLeftDown, text="Nome", width=.Width.but, height=.Height.but, command=function() nodenamewindows())
+ node.prob.but <- tkbutton(frameUpperLeftDown, text="Probabilidade", width=.Width.but, height=.Height.but, command=function() probwindows())
+ node.playoff.but <- tkbutton(frameUpperLeftDown, text="Valores", width=.Width.but, height=.Height.but, command=function() utilitywindows())
+ node.type <- tkbutton(frameUpperLeftDown, text="Tipo", width=.Width.but, height=.Height.but, command=function() typenodewindows())
+ node.add <- tkbutton(frameUpperLeftDown, text="Adicionar", width=.Width.but, height=.Height.but, command=function() addnodewindows())
+ node.remove <- tkbutton(frameUpperLeftDown, text="Remover", width=.Width.but, height=.Height.but, command=function() removenodewindows())
+ node.destiny <- tkbutton(frameUpperLeftDown, text="Destino", width=.Width.but, height=.Height.but, command=function() destinynodewindows())
+ node.notes <- tkbutton(frameUpperLeftDown, text="Comentários", width=.Width.but, height=.Height.but, command=function() notesnodewindows())
+
+ tkgrid(tklabel(frameUpperLeft,text = .Frametitle3))
+ tkgrid(node.name.but, row = 0, column = 0, sticky = "nw")
+ tkgrid(node.prob.but, row = 0, column = 1, sticky = "nw")
+ tkgrid(node.type, row = 1, column = 0, sticky = "nw")
+ tkgrid(node.playoff.but, row = 1, column = 1, sticky = "nw")
+ tkgrid(node.add, row = 2, column = 0, sticky = "nw")
+ tkgrid(node.remove, row = 2, column = 1, sticky = "nw")
+ tkgrid(node.destiny, row = 3, column = 0, sticky = "nw")
+ tkgrid(node.notes, row = 3, column = 1, sticky = "nw")
+
+ tkgrid(frameUpperLeftDown, sticky = "swe") #, side = "bottom", expand = 1, fill = "both")
+
+ # Image window configurations
+ Height <- 400
+ Width <- 600
+ Borderwidth <- 2
+
+ # scrollbar objects
+ Hscroll <- tkscrollbar(frameUpperRigth, orient="horiz", command = function(...)tkxview(Canvas,...) )
+ Vscroll <- tkscrollbar(frameUpperRigth, command = function(...)tkyview(Canvas,...) )
+ Canvas <- tkcanvas(frameUpperRigth, relief = "sunken", borderwidth = Borderwidth,
+ width = Width, height = Height,
+ xscrollcommand = function(...)tkset(Hscroll,...),
+ yscrollcommand = function(...)tkset(Vscroll,...)
+ )
+
+ assign("Canvas", Canvas, .EnvironmentArvoRe)
+
+ # Pack the scroll bars.
+ tkpack(Hscroll, side = "bottom", fill = "x")
+ tkpack(Vscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(Canvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image setings.
+ imgHeight <- 600
+ imgWidth <- 800
+
+ assign("imgHeight", imgHeight, .EnvironmentArvoRe)
+ assign("imgWidth", imgWidth, .EnvironmentArvoRe)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "arvore.png", sep="")
+
+ # unlink(x, recursive = FALSE)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(Canvas, "image", imgWidth/2, imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(Canvas, scrollregion = c(0,0,imgWidth,imgHeight))
+ file.remove(.Filename)
+
+
+ ###############################################################################
+ # The keys
+ ###############################################################################
+
+ tkbind(tt, "<Escape>",sair)
+ tkbind(tt, "<Control_L><n>",new.file.bot)
+ tkbind(tt, "<Control_L><o>",load.file.arv)
+ tkbind(tt, "<Control_L><Alt_L><s>",save.file.arv)
+ tkbind(tt, "<Control_L><s>",save.file.arv)
+ tkbind(tt, "<Control_L><e>",naoimplementado)
+ tkbind(tt, "<F5>",refreshF5)
+
+
+ ###############################################################################
+
+ posiciona.janela.tela(tt)
+ tkfocus(tt)
+ tkwm.deiconify(tt)
+ } else {
+ msg <- paste("O programa ÁrvoRe já está sendo executado.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ }
+}
+
Property changes on: pkg/R/arvore.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/atualiza.grafico.R
===================================================================
--- pkg/R/atualiza.grafico.R (rev 0)
+++ pkg/R/atualiza.grafico.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,21 @@
+`atualiza.grafico` <-
+function(...) {
+ .Filename <- paste(tempdir(),"\\", "arvore.png", sep="")
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(Canvas, "image", imgWidth/2, imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(Canvas, scrollregion = c(0,0,imgWidth,imgHeight))
+
+ file.remove(.Filename)
+ tkwm.deiconify(tt)
+}
+
Property changes on: pkg/R/atualiza.grafico.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/carregaTclpath.R
===================================================================
--- pkg/R/carregaTclpath.R (rev 0)
+++ pkg/R/carregaTclpath.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`carregaTclpath` <-
+function() {
+ addTclPath("C:/Tcl/lib")
+ addTclPath("C:/Arquivos de programas/Tcl/lib")
+}
+
Property changes on: pkg/R/carregaTclpath.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/changedofunction.R
===================================================================
--- pkg/R/changedofunction.R (rev 0)
+++ pkg/R/changedofunction.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+`changedofunction` <-
+function(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure) {
+ TheTree.old <- TheTree
+ .EnvironmentArvoRe.old <- .EnvironmentArvoRe
+ .modeltypeArvore.old <- .modeltypeArvore
+
+ assign("TheTree", get("TheTree", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+ assign(".EnvironmentArvoRe", get(".EnvironmentArvoRe", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+ assign(".modeltypeArvore", get(".modeltypeArvore", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+
+ safedofunction(TheTree.old, .EnvironmentArvoRe.old, .modeltypeArvore.old)
+ refreshF5()
+}
+
Property changes on: pkg/R/changedofunction.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/clearTreeTkArvore.R
===================================================================
--- pkg/R/clearTreeTkArvore.R (rev 0)
+++ pkg/R/clearTreeTkArvore.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,10 @@
+`clearTreeTkArvore` <-
+function(TheTree) {
+ i <- TheTree$Level
+ j <- TheTree$Node.N
+
+ osnodos <- paste(i,".",j,sep="")
+ tkdelete(treeWidget,osnodos[j])
+ tkdelete(treeWidget,"1.1")
+}
+
Property changes on: pkg/R/clearTreeTkArvore.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/convert2matrix.R
===================================================================
--- pkg/R/convert2matrix.R (rev 0)
+++ pkg/R/convert2matrix.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,131 @@
+`convert2matrix` <-
+function(TheTree) {
+
+ n.levels <- max(TheTree$Level)
+
+ x <- matrix(NA, 0, n.levels)
+ y <- matrix(NA, 0, n.levels)
+ probMAT <- matrix(NA, 0, n.levels)
+ typeMAT <- matrix(NA, 0, n.levels)
+ effectivenessMAT <- matrix(NA, 0, n.levels)
+ utilityMAT <- matrix(NA, 0, n.levels)
+ destinyMAT <- matrix(NA, 0, n.levels)
+
+ for (i in n.levels:1) {
+ Data.level <- TheTree[TheTree$Level == i,]
+ nodes <- as.numeric(levels(as.factor(Data.level$Node.N)))
+
+ line.x <- array(NA, n.levels)
+ line.y <- array(NA, n.levels)
+ line.prob <- array(1, n.levels)
+ line.type <- array(NA, n.levels)
+ line.effectiveness <- array(1, n.levels)
+ line.utility <- array(0, n.levels)
+ line.destiny <- array(NA, n.levels)
+
+ for (j in nodes) {
+ if (sum( x[,i] == j, na.rm = TRUE ) < 1) {
+ Data.Node <- Data.level[ Data.level$Node.N == j,]
+
+ father.node <- as.numeric(Data.Node$Father[1])
+ label.father <- Data.Node$Father.Name[1]
+
+ line.x[i] <- j
+ line.y[i] <- Data.Node$Node.name[1]
+ line.prob[i] <- Data.Node$Prob[1]
+ line.type[i] <- Data.Node$Type[1]
+ line.effectiveness[i] <- as.numeric(as.character(Data.Node$Payoff2[1]))
+ line.utility[i] <- as.numeric(as.character(Data.Node$Payoff1[1]))
+ line.destiny[i] <- Data.Node$Destiny[1]
+
+
+ if (i > 1) {
+ for (k in (i-1):1) {
+ line.x[k] <- father.node
+ line.y[k] <- label.father
+
+ Data.node.return <- TheTree[TheTree$Level == k,]
+ Data.node.return <- Data.node.return[Data.node.return$Node.N == as.character(line.x[k]),]
+ father.node <- as.numeric(Data.node.return$Father[1])
+ label.father <- Data.node.return$Father.Name
+ prob.father <- Data.node.return$Prob
+ type.father <- Data.node.return$Type
+ effectiveness.father <- Data.node.return$Payoff2[1]
+ utility.father <- Data.node.return$Payoff1[1]
+ destiny.father <- Data.node.return$Destiny
+
+ line.prob[k] <- prob.father
+ line.type[k] <- type.father
+ line.effectiveness[k] <- as.numeric(as.character(effectiveness.father))
+ line.utility[k] <- as.numeric(as.character(utility.father))
+ line.destiny[k] <- destiny.father
+
+ }
+ }
+ x <- rbind(x,line.x)
+ y <- rbind(y,line.y)
+ probMAT <- rbind(probMAT,line.prob)
+ typeMAT <- rbind(typeMAT,line.type)
+ effectivenessMAT <- rbind(effectivenessMAT,line.effectiveness)
+ utilityMAT <- rbind(utilityMAT,line.utility)
+ destinyMAT <- rbind(destinyMAT,line.destiny)
+ }
+ }
+ }
+
+ x <- as.matrix(x)
+ y <- as.matrix(y)
+ probMAT <- as.matrix(probMAT)
+ typeMAT <- as.matrix(typeMAT)
+ effectivenessMAT <- as.matrix(effectivenessMAT)
+ utilityMAT <- as.matrix(utilityMAT)
+ destinyMAT <- as.matrix(destinyMAT)
+
+# ordena as matrizes para nao haver problema com a plot.tree - June 21, 2008
+if(dim(x)[1] != 1) {
+ for (i in 1:dim(x)[2]) {
+ if ( sum(is.na(x[,i])) == 0 ) { # whatcolorder <- c(whatcolorder, i)
+ y <- y[order(x[,i]),]
+ probMAT <- probMAT[order(x[,i]),]
+ typeMAT <- typeMAT[order(x[,i]),]
+ effectivenessMAT <- effectivenessMAT[order(x[,i]),]
+ utilityMAT <- utilityMAT[order(x[,i]),]
+ destinyMAT <- destinyMAT[order(x[,i]),]
+ x <- x[order(x[,i]),]
+ }
+ }
+}
+
+ x <- as.matrix(x)
+ y <- as.matrix(y)
+ probMAT <- as.matrix(probMAT)
+ typeMAT <- as.matrix(typeMAT)
+ effectivenessMAT <- as.matrix(effectivenessMAT)
+ utilityMAT <- as.matrix(utilityMAT)
+ destinyMAT <- as.matrix(destinyMAT)
+
+ colnames(x) <- NULL
+ rownames(x) <- NULL
+ colnames(y) <- NULL
+ rownames(y) <- NULL
+ colnames(probMAT) <- NULL
+ rownames(probMAT) <- NULL
+ colnames(typeMAT) <- NULL
+ rownames(typeMAT) <- NULL
+ colnames(effectivenessMAT) <- NULL
+ rownames(effectivenessMAT) <- NULL
+ colnames(utilityMAT) <- NULL
+ rownames(utilityMAT) <- NULL
+ colnames(destinyMAT) <- NULL
+ rownames(destinyMAT) <- NULL
+ dl <- dim(destinyMAT)[1]
+ destinyarray <- array(0,dl)
+ for (i in 1:dl) {
+ balde <- destinyMAT[i, !is.na(destinyMAT[i,]) ]
+ destinyarray[i] <- balde[length(balde)]
+ }
+ ans <- list( x = x, y = y, probMAT = probMAT, typeMAT = typeMAT, effectivenessMAT = effectivenessMAT,
+ utilityMAT = utilityMAT, destinyMAT = destinyarray)
+ return(ans)
+}
+
Property changes on: pkg/R/convert2matrix.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/cost.effectiveness.table.R
===================================================================
--- pkg/R/cost.effectiveness.table.R (rev 0)
+++ pkg/R/cost.effectiveness.table.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,76 @@
+`cost.effectiveness.table` <-
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+ x <- Matrixset$x
+ y <- Matrixset$y
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+ typeMAT <- Matrixset$typeMAT
+
+ rollbackLIST <- rollback(TheTree)
+
+ num.col <- dim(x)[2]
+ num.lin <- dim(x)[1]
+
+ levelnode <- array(,0)
+ paispos <- array(,0)
+ nnode <- array(,0)
+ namenode <- array(,0)
+ probnode <- array(,0)
+ utilitynode <- array(,0)
+ effectivenessnode <- array(,0)
+ typenode <- array(,0)
+ paisnodos.n <- array(,0)
+ paisnodos.name <- array(,0)
+ paisnodos <- array(,0)
+ expectedvalue.cost <- array(,0)
+ expectedvalue.effectiveness <- array(,0)
+ expectedvalue.ce <- array(,0)
+
+ for (i in 1:num.col) {
+ max.node <- max(x[,i], na.rm = TRUE)
+ pais <- 1:max.node
+ for (k in pais) {
+ levelnode <- c(levelnode,i)
+ nodepos <- which(x[,i] == k)[1]
+ paispos <- c(paispos, nodepos)
+ if (i == 1) {
+ paisnodos.n <- c(paisnodos.n, 1)
+ paisnodos.name <- c(paisnodos.name, " ")
+ } else {
+ paisnodos.n <- c(paisnodos.n, x[nodepos, i-1])
+ paisnodos.name <- c(paisnodos.name, y[nodepos, i-1])
+ }
+ nnode <- c(nnode, k)
+ namenode <- c(namenode, y[nodepos, i])
+ probnode <- c(probnode, probMAT[nodepos, i])
+ utilitynode <- c(utilitynode, utilityMAT[nodepos, i])
+ effectivenessnode <- c(effectivenessnode, effectivenessMAT[nodepos, i])
+ typenode <- c(typenode, typeMAT[nodepos, i])
+ expectedvalue.cost <- c(expectedvalue.cost, rollbackLIST[["Cost"]][nodepos, i])
+ expectedvalue.effectiveness <- c(expectedvalue.effectiveness, rollbackLIST[["Effectiveness"]][nodepos, i])
+ expectedvalue.ce <- c(expectedvalue.ce, rollbackLIST[["CE"]][nodepos, i])
+
+ }
+ }
+
+ tabela <- data.frame(Level = levelnode, Node.N = nnode, Node.name = namenode,
+ Mean.Cost = expectedvalue.cost,
+ Mean.Effectiveness = expectedvalue.effectiveness,
+ Mean.C.E.ratio = expectedvalue.ce
+ )
+
+ tabela <- subset(tabela, Level == 2)
+ tabela <- as.data.frame(tabela)
+
+ tabela$Level <- as.numeric(tabela$Level)
+ tabela$Node.N <- as.numeric(tabela$Node.N)
+ tabela$Node.name <- as.character(tabela$Node.name)
+ tabela$Mean.Cost <- as.numeric(as.numeric(tabela$Mean.Cost))
+ tabela$Mean.Effectiveness <- as.numeric(as.numeric(tabela$Mean.Effectiveness))
+ tabela$Mean.C.E.ratio <- as.numeric(as.numeric(tabela$Mean.C.E.ratio))
+
+ return(tabela)
+}
+
Property changes on: pkg/R/cost.effectiveness.table.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/destinynodewindows.R
===================================================================
--- pkg/R/destinynodewindows.R (rev 0)
+++ pkg/R/destinynodewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,101 @@
+`destinynodewindows` <-
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( .modeltypeArvore != "CE") {
+ msg <- paste(" Você não está utilizando um modelo Markov.\n Altere o tipo de modelo para poder definir destino a um nodo.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ node.type <- TheTree$Type[position]
+
+
+ if (node.type == "T") {
+ node.Origins <- select.origins(TheTree, node.col = column, node.number = node.number)
+ position.exist.markov <- which(node.Origins$Type == "M")
+
+ if (length(position.exist.markov) > 0) {
+ destinyWindow <- tktoplevel()
+ title <- "ÁrvoRe - Destino do Nodo"
+ tkwm.title(destinyWindow,title)
+
+ position.exist.markov <- max(position.exist.markov)
+ column.markov <- node.Origins$Level[position.exist.markov]
+ number.markov.node <- node.Origins$Node.N[position.exist.markov]
+
+ k <- subset(TheTree, Level == column.markov + 1)
+ k <- subset(k, Father == number.markov.node)
+ k <- k[union( which(k$Type == "C"), which(k$Type == "T")), ]
+
+ markov.nodes <- as.character(k$Node.name)
+ markov.nodes.position <- as.numeric(k$Node.N)
+ markov.nodes.col <- as.numeric(k$Level)
+
+ heightlistbox <- length(markov.nodes)
+
+ scr <- tkscrollbar(destinyWindow, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ tl <- tklistbox(destinyWindow,height=heightlistbox,selectmode="single",
+ yscrollcommand=function(...)tkset(scr,...),background="white")
+ tkgrid(tklabel(destinyWindow,text="Seleciona um nodo de destino"))
+ tkgrid(tl,scr)
+ tkgrid.configure(scr,rowspan=4,sticky="nsw")
+
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl,"end",markov.nodes[i])
+ }
+
+ if(TheTree$Destiny[position[1]] != " ") {
+ selected <- which( markov.nodes.position == as.numeric(TheTree$Destiny[position[1]]))
+ tkselection.set(tl,selected-1)
+ }
+
+ OnOK <- function()
+ {
+ destinyChoice <- markov.nodes.position[as.numeric(tkcurselection(tl))+1]
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ TheTree$Destiny[position] <- destinyChoice
+ setdestinynode(TheTree, .EnvironmentArvoRe)
+ tkdestroy(destinyWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(destinyWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(destinyWindow,text=" OK ",command=OnOK)
+ tkbind(destinyWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(destinyWindow,text=" Cancelar ",command=OnCancel)
+ tkbind(destinyWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(destinyWindow, 230, 150)
+
+ tkfocus(destinyWindow)
+ } else {
+ msg <- paste("O nodo selecionado não é um nodo de transição de um nodo tipo 'Markov'. \n Apenas nodos desse tipo podem seguir um destino.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ } else {
+ msg <- paste("O nodo selecionado não é um nodo do tipo 'Terminal'. \n Apenas nodos desse tipo podem seguir um destino.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+
+ }
+ }
+}
+
Property changes on: pkg/R/destinynodewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/dialog.simulation.window.R
===================================================================
--- pkg/R/dialog.simulation.window.R (rev 0)
+++ pkg/R/dialog.simulation.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,393 @@
+`dialog.simulation.window` <-
+function(...) {
+ .begin.sim <- TRUE # Servirá como flag para se saber se se pode iniciar a simulação.
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ .begin.sim <- FALSE
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ }
+ TestPartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)$Type
+ position.test <- which( TestPartialTree == "M" )
+ if (length(position.test) > 0) {
+ if (dim(markov.propertiesMAT)[1] == 0) {
+ msg <- paste("Propriedades dos nodos representantes dos estados Markov não \n",
+ "foram definidos. Use o botão 'M' para ajustar as propriedades \n",
+ "destes nodos.", sep = "")
+ tkmessageBox(message = msg, icon="error", title = "ÁrvoRe - AVISO")
+ .begin.sim <- FALSE
+ tkfocus(tt)
+ }
+ }
+ if (.begin.sim) {
+ if (node.type == "M") {
+############ MARKOV ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Simulação Markov"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Individuosvar <- tclVar(10000)
+ Terminalvar <- tclVar("(.stage >= 10)")
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Individuos.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Individuosvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Individuos.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+ Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Condição de término da simulação"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Terminal.Value, row = 5, column = 0, columnspan = 2, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ IndividuosVal <- as.integer(tclvalue(Individuosvar))
+ TerminalVal <- as.character(tclvalue(Terminalvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(IndividuosVal)) && (!is.na(IndividuosVal)) && (nchar(IndividuosVal) > 0) ) {
+ PartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)
+ Partialmarkov.propertiesMAT <- select.markov.propertiesMAT(TheTree, PartialTree, markov.propertiesMAT)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Mktable <- markov.coort.table(PartialTree, Partialmarkov.propertiesMAT, markov.termination = TerminalVal,
+ initial.coort = IndividuosVal, seed = SeedVal, absorventstatedeath = .absorventstateconf)
+ tempo2 <- Sys.time()
+# assign("Mktable", Mktable, .EnvironmentArvoRe)
+ Mktable <- list(Mktable)
+ names(Mktable) <- TheTree$Node.name[position]
+ summary.simulation.window(Mktable,
+ tempo1 = tempo1,
+ tempo2 = tempo2,
+ CicloVal = dim(Mktable)[1],
+ tipo.nodo = "M",
+ digits = .digits)
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",IndividuosVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Individuos.Value, "<Return>",OnOK)
+ tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 250, 200)
+# tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "D") {
+############ DECISION ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Simulação Markov"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Individuosvar <- tclVar(10000)
+ Terminalvar <- tclVar("(.stage >= 10)")
+ Trialssvar <- tclVar(10000)
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Individuos.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Individuosvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte (Markov) \n Número de repetições (random walk) (Chance/Terminal)"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Individuos.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+ Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Condição de término da simulação"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Terminal.Value, row = 5, column = 0, columnspan = 2, sticky = "n")
+
+# Trialss.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Trialssvar)
+# tkgrid(tklabel(dialogsimulationwindow,text="Número de repetições (random walk)"),
+# row = 6, column = 0, columnspan = 2, sticky = "n")
+# tkgrid(Trialss.Value, row = 7, column = 0, columnspan = 2, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ IndividuosVal <- as.integer(tclvalue(Individuosvar))
+ TerminalVal <- as.character(tclvalue(Terminalvar))
+ TrialssVal <-IndividuosVal
+# TrialssVal <- as.integer(tclvalue(Trialssvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(IndividuosVal)) && (!is.na(IndividuosVal)) && (nchar(IndividuosVal) > 0) ) {
+ nodestoSim <- subset(TheTree, Level == column + 1)
+ nodestoSim <- subset(nodestoSim, Father == node.number)
+
+ Times.to.sim.init <- array(,0)
+ Times.to.sim.final <- array(,0)
+
+ Names.to.sim <- array(,0)
+ Types.to.sim <- array(,0)
+
+ Sim.list.to.resume <- list()
+
+ for ( nodeinquestion in 1:length(nodestoSim$Node.N) ) {
+ nodegotosim.Type <- nodestoSim$Type[nodeinquestion]
+ nodegotosim.Name <- nodestoSim$Node.name[nodeinquestion]
+ nodegotosim.Node.N <- nodestoSim$Node.N[nodeinquestion]
+ nodegotosim.Level <- nodestoSim$Level[nodeinquestion]
+
+ if ( nodegotosim.Type == "M") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ Partialmarkov.propertiesMAT <- select.markov.propertiesMAT(TheTree,
+ PartialTree,
+ markov.propertiesMAT)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- markov.coort.table(PartialTree,
+ markov.propertiesMAT = Partialmarkov.propertiesMAT,
+ markov.termination = TerminalVal,
+ initial.coort = IndividuosVal,
+ seed = SeedVal,
+ absorventstatedeath = .absorventstateconf)
+ tempo2 <- Sys.time()
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "M")
+ }
+ if ( nodegotosim.Type == "C") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- simple.markov.coort.table(PartialTree,
+ trials = TrialssVal,
+ seed = SeedVal)
+ tempo2 <- Sys.time()
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "C")
+ }
+ if ( nodegotosim.Type == "T") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- terminal.markov.coort.table(PartialTree, trials = TrialssVal)
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "T")
+# cat("NODO Terminal : fazendo nada | dialog.simulation() \n")
+ }
+ }
+ names(Sim.list.to.resume) <- Names.to.sim
+ summary.simulation.window(Sim.list.to.resume,
+ tempo1 = Times.to.sim.init,
+ tempo2 = Times.to.sim.final,
+ CicloVal = 999,
+ tipo.nodo = Types.to.sim,
+ digits = .digits)
+
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",IndividuosVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Individuos.Value, "<Return>",OnOK)
+ tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 300, 200)
+ # tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "C") {
+############ CHANCE ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Simulação Markov"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Trialssvar <- tclVar(10000)
+# Terminalvar <- tclVar("(.stage >= 10)")
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Trialss.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Trialssvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de repetições (random walk)"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Trialss.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+# Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+# tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte"), sticky = "n")
+# tkgrid(Terminal.Value, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ TrialssVal <- as.integer(tclvalue(Trialssvar))
+# TerminalVal <- as.character(tclvalue(Terminalvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(TrialssVal)) && (!is.na(TrialssVal)) && (nchar(TrialssVal) > 0) ) {
+ PartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Mktable <- simple.markov.coort.table(PartialTree, trials = TrialssVal, seed = SeedVal)
+ tempo2 <- Sys.time()
+# assign("Mktable", Mktable, .EnvironmentArvoRe)
+ Mktable <- list(Mktable)
+ names(Mktable) <- TheTree$Node.name[position]
+ summary.simulation.window(Mktable,
+ tempo1 = tempo1,
+ tempo2 = tempo2,
+ CicloVal = dim(Mktable)[1],
+ tipo.nodo = "C",
+ digits = .digits)
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",TrialssVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Trialss.Value, "<Return>",OnOK)
+# tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 250, 150)
+ # tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "T") {
+############ TERMINAL ############
+ msg <- paste("O nodo selecionado é do tipo 'Terminal'. Selecione um outro \n nodo da árvore para executar simulação.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+#
+# PartialTree <- select.subtree(TheTree,
+# node.col = column, node.number = node.number,
+# change.row.names = FALSE)
+# tempo1 <- Sys.time()
+# Mktable <- terminal.markov.coort.table(PartialTree)
+# print(Mktable)
+# tempo2 <- Sys.time()
+# summary.simulation.window(Mktable,
+# tempo1 = tempo1,
+# tempo2 = tempo2,
+# CicloVal = dim(Mktable)[1],
+# tipo.nodo = "M",
+# digits = .digits)
+ } else {
+ cat("ERROR: Tipo não reconhecido \n")
+ msg <- paste("O nodo selecionado é de tipo não reconhecido. Selecione um outro \n nodo da árvore para executar simulação.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+ }
+ }
+
+ }
+}
+
Property changes on: pkg/R/dialog.simulation.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/dialog.variable.window.R
===================================================================
--- pkg/R/dialog.variable.window.R (rev 0)
+++ pkg/R/dialog.variable.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,320 @@
+`dialog.variable.window` <-
+function(...) {
+ if (!exists("variableMAT",.EnvironmentArvoRe)) new.variable.list() # se não existe uma tabela de variaveis, então ele cria.
+
+ variableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(variableWindow,title)
+
+ frameOverall <- tkframe(variableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=2)
+
+ scrvar <- tkscrollbar(frameUpperRigth, repeatinterval=5,
+ command=function(...)tkyview(tlvar,...))
+ tlvar <- tklistbox(frameUpperRigth,height=4,selectmode="single",
+ yscrollcommand=function(...)tkset(scrvar,...),background="white")
+ tkgrid(tklabel(frameUpperRigth,text="Variáveis"))
+ tkgrid(tlvar,scrvar)
+ tkgrid.configure(scrvar,rowspan=4,sticky="nsw")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="nsw")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ variablesnames <- variableMAT[,1]
+
+ if (length(variablesnames) > 0) {
+ for (i in (1:length(variablesnames))) {
+ tkinsert(tlvar,"end",variablesnames[i])
+ }
+ }
+
+ AddSelection <- function()
+ {
+ addvariableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(addvariableWindow,title)
+
+ frameOverall <- tkframe(addvariableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameOverall,text="Nova Variável"))
+
+ Namevar <- tclVar("")
+ Fixvar <- tclVar(0)
+ Minvar <- tclVar(0)
+ Maxvar <- tclVar(0)
+ Notesvar <- tclVar("")
+
+ campowidth <- 25
+ Name.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Namevar)
+ tkgrid(tklabel(frameUpper,text="Nome da variável"), sticky = "n")
+ tkgrid(Name.var.Value, sticky = "n")
+
+ Fix.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Fixvar)
+ tkgrid(tklabel(frameUpper,text="Valor padrão da variável"), sticky = "n")
+ tkgrid(Fix.var.Value, sticky = "n")
+
+ Min.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Minvar)
+ tkgrid(tklabel(frameUpper,text="Valor mínimo da variável"), sticky = "n")
+ tkgrid(Min.var.Value, sticky = "n")
+
+ Max.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Maxvar)
+ tkgrid(tklabel(frameUpper,text="Valor máximo da variável"), sticky = "n")
+ tkgrid(Max.var.Value, sticky = "n")
+
+ Notes.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Notesvar)
+ tkgrid(tklabel(frameUpper,text="Notas"), sticky = "n")
+ tkgrid(Notes.var.Value, sticky = "n")
+
+ OnOkAdd <- function() {
+ Allok <- TRUE
+ NameVal <- as.character(tclvalue(Namevar))
+ FixVal <- as.integer(tclvalue(Fixvar))
+ MinVal <- as.integer(tclvalue(Minvar))
+ MaxVal <- as.integer(tclvalue(Maxvar))
+ NotesVal <- as.character(tclvalue(Notesvar))
+
+ if((nchar(NameVal) <= 0)&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um nome válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(FixVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor fixo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MinVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor mínimo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MaxVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor máximo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((MinVal >= MaxVal)&& Allok) {
+ Allok <- FALSE
+ msg <- "O valor mínimo de uma variável deve ser menor que o valor máximo."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if(Allok) {
+ newvariableline <- data.frame(Name = NameVal, Fix.Value = FixVal, Min.Value = MinVal,
+ Max.Value = MaxVal, Notes = NotesVal)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline, action = "add")
+ tkinsert(tlvar,"end",NameVal)
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ }
+
+ OnCanceladd <- function() {
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOkAdd)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCanceladd)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(addvariableWindow, "<Return>",OnOkAdd)
+ tkbind(addvariableWindow, "<Escape>",OnCanceladd)
+
+ tkfocus(addvariableWindow)
+ }
+
+ DeleteSelection <- function()
+ {
+ variableIndex <- as.integer(tkcurselection(tlvar))
+ variableslist <- variableMAT$Name
+ variabletodelete <- as.character(variableslist[variableIndex+1])
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setvariablelist(variableMAT = variableMAT, variable.name = variabletodelete, action = "delete")
+ tkdelete(tlvar,variableIndex)
+ tkfocus(variableWindow)
+ }
+
+ EditSelection <- function()
+ {
+ variableIndex <- as.integer(tkcurselection(tlvar))
+
+ variableslist <- variableMAT$Name
+ variableselected <- as.character(variableslist[variableIndex+1])
+
+ addvariableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(addvariableWindow,title)
+
+ frameOverall <- tkframe(addvariableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameOverall,text="Propriedades da Variável"))
+
+ variableMATnames <- names(variableMAT)
+ Data <- subset(variableMAT, Name == variableselected, select = variableMATnames)
+
+ Namevar <- tclVar(Data$Name)
+ Fixvar <- tclVar(Data$Fix.Value)
+ Minvar <- tclVar(Data$Min.Value)
+ Maxvar <- tclVar(Data$Max.Value)
+ Notesvar <- tclVar(Data$Notes)
+
+ campowidth <- 25
+ Name.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Namevar)
+ tkgrid(tklabel(frameUpper,text="Nome da variável"), sticky = "n")
+ tkgrid(Name.var.Value, sticky = "n")
+
+ Fix.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Fixvar)
+ tkgrid(tklabel(frameUpper,text="Valor padrão da variável"), sticky = "n")
+ tkgrid(Fix.var.Value, sticky = "n")
+
+ Min.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Minvar)
+ tkgrid(tklabel(frameUpper,text="Valor mínimo da variável"), sticky = "n")
+ tkgrid(Min.var.Value, sticky = "n")
+
+ Max.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Maxvar)
+ tkgrid(tklabel(frameUpper,text="Valor máximo da variável"), sticky = "n")
+ tkgrid(Max.var.Value, sticky = "n")
+
+ Notes.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Notesvar)
+ tkgrid(tklabel(frameUpper,text="Notas"), sticky = "n")
+ tkgrid(Notes.var.Value, sticky = "n")
+
+ OnOkAdd <- function() {
+ Allok <- TRUE
+ NameVal <- as.character(tclvalue(Namevar))
+ FixVal <- as.integer(tclvalue(Fixvar))
+ MinVal <- as.integer(tclvalue(Minvar))
+ MaxVal <- as.integer(tclvalue(Maxvar))
+ NotesVal <- as.character(tclvalue(Notesvar))
+
+ if((nchar(NameVal) <= 0)&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um nome válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(FixVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor fixo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MinVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor mínimo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MaxVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor máximo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((MinVal >= MaxVal)&& Allok) {
+ Allok <- FALSE
+ msg <- "O valor mínimo de uma variável deve ser menor que o valor máximo."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if(Allok) {
+ oldvariable.name <- Data$Name
+ newvariableline <- data.frame(Name = NameVal, Fix.Value = FixVal, Min.Value = MinVal,
+ Max.Value = MaxVal, Notes = NotesVal)
+
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ if (length(oldvariable.name) == 0) {
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline,
+ action = "add")
+ oldvariable.name <- " "
+ } else {
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline,
+ variable.name = oldvariable.name, action = "edit")
+ }
+
+ if (oldvariable.name != NameVal) {
+ if (oldvariable.name != " ") tkdelete(tlvar,variableIndex)
+ tkinsert(tlvar,"end",NameVal)
+ }
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ }
+
+ OnCanceladd <- function() {
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOkAdd)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCanceladd)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(addvariableWindow, "<Return>",OnOkAdd)
+ tkbind(addvariableWindow, "<Escape>",OnCanceladd)
+
+ tkfocus(addvariableWindow)
+
+ }
+
+ OnOK <- function()
+ {
+ tkdestroy(variableWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameOverall,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Edit.but <-tkbutton(frameUpperLeft,text="Editar", width=.Width.but, height=.Height.but,command=EditSelection)
+ Add.but <-tkbutton(frameUpperLeft,text="Nova", width=.Width.but, height=.Height.but,command=AddSelection)
+ Delete.but <-tkbutton(frameUpperLeft,text="Apagar", width=.Width.but, height=.Height.but,command=DeleteSelection)
+
+ tkbind(variableWindow, "<Return>",OnOK)
+ tkbind(variableWindow, "<Escape>",OnOK)
+
+ tkgrid(OK.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Add.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Delete.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Edit.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameOverall)
+
+ posiciona.janela.no.mouse(variableWindow, 250, 160)
+
+ tkfocus(variableWindow)
+}
+
Property changes on: pkg/R/dialog.variable.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/dimensoes.janela.R
===================================================================
--- pkg/R/dimensoes.janela.R (rev 0)
+++ pkg/R/dimensoes.janela.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,26 @@
+`dimensoes.janela` <-
+function(janela, height, width) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela) ) )
+
+ wm.x <- as.integer( tclvalue( tkwinfo("x", janela) ) )
+ wm.y <- as.integer( tclvalue( tkwinfo("y", janela) ) )
+
+ if( height > MAX.height ) height <- MAX.height
+ if( width > MAX.width ) width <- MAX.width
+
+ limite.sup.x <- round( MAX.width - width )
+ limite.inf.x <- round( width )
+ limite.sup.y <- round( MAX.height - height )
+ limite.sup.y <- round( height )
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$%#$%
+ if (wm.x > limite.sup.x) wm.x <- limite.sup.x
+ if (wm.x < limite.inf.x) wm.x <- limite.inf.x
+ if (wm.y > limite.sup.y) wm.y <- limite.sup.y
+ if (wm.y > limite.sup.y) wm.y <- limite.sup.y
+
+ posicao <- paste(width, "x", height, "+", wm.x,"+", wm.y, sep="")
+ tkwm.geometry(janela,posicao)
+}
+
Property changes on: pkg/R/dimensoes.janela.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/displayInTable.R
===================================================================
--- pkg/R/displayInTable.R (rev 0)
+++ pkg/R/displayInTable.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,181 @@
+`displayInTable` <-
+function(matrix1,title="",height=-1,width=-1,nrow=-1,ncol=-1,
+ titlerows = FALSE, titlecols = FALSE, editable = FALSE,
+ returntt = TRUE) {
+ require(tcltk)
+
+ Original.Dada <- matrix1
+
+ num.lin <- dim(matrix1)[1]
+ num.col <- dim(matrix1)[2]
+
+ if (titlecols && (!titlerows)) {
+ TitleCols <- colnames(matrix1)
+ if (is.null(colnames(matrix1))) TitleCols <- paste("Col ", 1:num.col, sep="")
+ matrix1 <- rbind(TitleCols, matrix1)
+ nrow <- nrow + 1
+ }
+
+ if ( titlerows && (!titlecols) ) {
+ TitleRows <- rownames(matrix1)
+ if (is.null(rownames(matrix1))) TitleRows <- paste("Row ", 1:num.lin, sep="")
+ matrix1 <- cbind(TitleRows, matrix1)
+ ncol <- ncol + 1
+ } else {
+ if ( titlerows && titlecols ) {
+ TitleCols <- colnames(matrix1)
+ if (is.null(colnames(matrix1))) TitleCols <- paste("Col ", 1:num.col, sep="")
+ matrix1 <- rbind(TitleCols, matrix1)
+ TitleRows <- rownames(matrix1)
+ if (is.null(rownames(matrix1))) TitleRows <- paste("Row ", 1:num.lin, sep="")
+ TitleRows <- c(" ", TitleRows)
+ matrix1 <- cbind(TitleRows, matrix1)
+ ncol <- ncol + 1
+ nrow <- nrow + 1
+ }
+ }
+
+ num.lin <- dim(matrix1)[1]
+ num.col <- dim(matrix1)[2]
+
+# remover se nao funcionar
+ matrix1 <- matrix(as.character(matrix1), num.lin, num.col)
+#---------------------------
+
+# tamanhocoluna <- max(nchar(matrix1))
+
+ tclarray <- tclArray()
+ for (i in (1:num.lin))
+ for (j in (1:num.col))
+ tclarray[[i-1,j-1]] <- matrix1[i,j]
+
+ if( editable ) {
+ editable <- "normal"
+ } else {
+ editable <- "disabled"
+ }
+
+ displayInTableWindow <- tktoplevel()
+ tclRequire("Tktable")
+ tkwm.title(displayInTableWindow,title)
+
+ table1 <- tkwidget(displayInTableWindow,"table",rows=nrow,cols=ncol,
+ titlerows = sum(titlecols), titlecols = sum(titlerows),
+ height=height+1,width=width+1,
+ xscrollcommand=function(...) tkset(xscr,...),yscrollcommand=function(...) tkset(yscr,...),
+ state = editable,
+ colstretchmode = "all")
+# colwidth = tamanhocoluna)
+ xscr <-tkscrollbar(displayInTableWindow,orient="horizontal", command=function(...)tkxview(table1,...))
+ yscr <- tkscrollbar(displayInTableWindow,command=function(...)tkyview(table1,...))
+
+ tkgrid(table1, yscr, columnspan = 2)
+
+ tkgrid.configure(yscr, sticky="nsw")
+ tkgrid.configure(table1, sticky="nswe")
+
+ tkgrid(xscr, sticky="new", columnspan = 2)
+
+ tkconfigure(table1,variable=tclarray,background="white",selectmode="extended")
+
+ OnExport <- function(Original.Dada) {
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(filetypeWindow)
+ else {
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ tkfocus(displayInTableWindow)
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(displayInTableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+
+ OnOK <- function() {
+ tkdestroy(displayInTableWindow)
+ if (returntt) {
+ tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(displayInTableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <-tkbutton(displayInTableWindow,text="Exportar", width=.Width.but, height=.Height.but, command=function() {OnExport(Original.Dada)})
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(displayInTableWindow, "<Return>",OnOK)
+ tkbind(displayInTableWindow, "<Escape>",OnOK)
+
+ tkfocus(displayInTableWindow)
+}
+
Property changes on: pkg/R/displayInTable.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/exec.text.R
===================================================================
--- pkg/R/exec.text.R (rev 0)
+++ pkg/R/exec.text.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`exec.text` <-
+function(x) {
+ ans <- try( eval(parse(text = x)) )
+ return(ans)
+}
+
Property changes on: pkg/R/exec.text.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/export.global.R
===================================================================
--- pkg/R/export.global.R (rev 0)
+++ pkg/R/export.global.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,5 @@
+`export.global` <-
+function(x, nome) {
+ assign(nome, x, env = .GlobalEnv)
+}
+
Property changes on: pkg/R/export.global.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/export.tree.graph.R
===================================================================
--- pkg/R/export.tree.graph.R (rev 0)
+++ pkg/R/export.tree.graph.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,157 @@
+`export.tree.graph` <-
+function(...) {
+
+ exportgraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportgraphWindow,title)
+
+ frameOverall <- tkframe(exportgraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function()
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ jpeg(filename = .Filename, width = imgWidth, height = imgHeight,
+ units = "px", pointsize = 12, quality = ImgQualityselected, bg = "white",
+ res = NA, restoreConsole = TRUE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ bmp(filename = .Filename, width = imgWidth, height = imgHeight,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = TRUE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ }
+ }
+ tkdestroy(exportgraphWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportgraphWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportgraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportgraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportgraphWindow)
+ posiciona.janela.no.mouse(exportgraphWindow)
+}
+
Property changes on: pkg/R/export.tree.graph.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/icer.sim.window.R
===================================================================
--- pkg/R/icer.sim.window.R (rev 0)
+++ pkg/R/icer.sim.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,186 @@
+`icer.sim.window` <-
+function(Alltreatmentstable) {
+ require(abind)
+
+ CEsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(CEsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(CEsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # Monta os frames
+ tkgrid(Frame1, Frame2, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+# print(Data.alternative.Cost)
+# print(Data.standart.Cost)
+# print(Data.alternative.Effectiveness)
+# print(Data.standart.Effectiveness)
+# print(Data.alternative.CE)
+# print(Data.standart.CE)
+
+# Data.alternative.Cost$Mean <- as.numeric(as.character(Data.alternative.Cost$Mean))
+# Data.alternative.Effectiveness$Mean <- as.numeric(as.character(Data.alternative.Effectiveness$Mean))
+# Data.alternative.Cost$Variance <- as.numeric(as.character(Data.alternative.Cost$Variance))
+# Data.alternative.Effectiveness$Variance <- as.numeric(as.character(Data.alternative.Effectiveness$Variance))
+# Data.alternative.Cost$CovDcDe <- as.numeric(as.character(Data.alternative.Cost$CovDcDe))
+# Data.alternative.Effectiveness$CovDcDe <- as.numeric(as.character(Data.alternative.Effectiveness$CovDcDe))
+# Data.standart.Cost$Mean <- as.numeric(as.character(Data.standart.Cost$Mean))
+# Data.standart.Effectiveness$Mean <- as.numeric(as.character(Data.standart.Effectiveness$Mean))
+# Data.standart.Cost$Variance <- as.numeric(as.character(Data.standart.Cost$Variance))
+# Data.standart.Effectiveness$Variance <- as.numeric(as.character(Data.standart.Effectiveness$Variance))
+# Data.standart.Cost$CovDcDe <- as.numeric(as.character(Data.standart.Cost$CovDcDe))
+# Data.standart.Effectiveness$CovDcDe <- as.numeric(as.character(Data.standart.Effectiveness$CovDcDe))
+
+
+ ans <- data.frame( Strategy = Data.standart.Cost$Treatment[1],
+ Cost = Data.standart.Cost$Mean[1],
+ Incr.Cost = NA,
+ Effectiveness = Data.standart.Effectiveness$Mean[1],
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart.Cost$Mean[1] / Data.standart.Effectiveness$Mean[1],
+ ICER = NA,
+ Var.ICER = NA,
+ Sd.ICER = NA,
+ LL_IC95 = NA,
+ UL_IC95 = NA
+ )
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ ans$Strategy <- as.character(ans$Strategy)
+ ans$Cost <- as.numeric(as.character(ans$Cost))
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Effectiveness <- as.numeric(as.character(ans$Effectiveness))
+ ans$Incr.Eff. <- as.numeric(as.character(ans$Incr.Eff.))
+ ans$CE.ratio <- as.numeric(as.character(ans$CE.ratio))
+ ans$ICER <- as.numeric(as.character(ans$ICER))
+ ans$Var.ICER <- as.numeric(as.character(ans$Var.ICER))
+ ans$Sd.ICER <- as.numeric(as.character(ans$Sd.ICER))
+ ans$LL_IC95 <- as.numeric(as.character(ans$LL_IC95))
+ ans$UL_IC95 <- as.numeric(as.character(ans$UL_IC95))
+
+
+ icer <- (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1]) /
+ (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1])
+
+ var.icer <- ( icer ) * (
+ ( Data.alternative.Effectiveness$Variance[i] / Data.alternative.Effectiveness$Mean[i]^2 ) +
+ ( Data.alternative.Cost$Variance[i] / Data.alternative.Cost$Mean[i]^2 ) -
+ 2 * ( Data.alternative.Cost$CovDcDe[i] ) /
+ ( Data.alternative.Effectiveness$Mean[i] / Data.alternative.Cost$Mean[i] )
+ )
+ print(var.icer)
+
+ var.icer <- as.numeric(as.character(var.icer))
+
+ ans.line <- data.frame( Strategy = Data.alternative.Cost$Treatment[i],
+ Cost = Data.alternative.Cost$Mean[i],
+ Incr.Cost = Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1],
+ Effectiveness = Data.alternative.Effectiveness$Mean[i],
+ Incr.Eff. = Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1],
+ CE.ratio = Data.alternative.Cost$Mean[i] / Data.alternative.Effectiveness$Mean[i],
+ ICER = icer,
+ Var.ICER = var.icer,
+ Sd.ICER = (var.icer)^(1/2),
+ LL_IC95 = icer - qnorm(1 - 0.05/2) * var.icer^0.5,
+ UL_IC95 = icer + qnorm(1 - 0.05/2) * var.icer^0.5
+ )
+ ans <- rbind(ans, ans.line) #, along = 1)
+ ans <- as.data.frame(ans)
+
+ }
+ ans <- as.data.frame(ans)
+
+# print(ans)
+
+ displayInTable(as.matrix(ans), title="ICER - Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ rm(ans)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(CEsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(CEsimtableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(CEsimtableWindow,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(CEsimtableWindow, "<Return>",OnOK)
+ tkbind(CEsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(CEsimtableWindow, 300, 180)
+
+ tkfocus(CEsimtableWindow)
+
+}
+
Property changes on: pkg/R/icer.sim.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/inb.sim.window.R
===================================================================
--- pkg/R/inb.sim.window.R (rev 0)
+++ pkg/R/inb.sim.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,157 @@
+`inb.sim.window` <-
+function(Alltreatmentstable) {
+ require(abind)
+
+ INBsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - INB"
+ tkwm.title(INBsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(INBsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # The WTP
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(Frame1,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(Frame1,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ # Monta os frames
+ tkgrid(Frame1, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(Frame2, sticky = "s", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+ WTPVal <- as.numeric(tclvalue(WTPvar))
+
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+ ans <- data.frame( Strategy = Data.standart.Cost$Treatment[1],
+ Cost = Data.standart.Cost$Mean[1],
+ Incr.Cost = NA,
+ Effectiveness = Data.standart.Effectiveness$Mean[1],
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart.Cost$Mean[1] / Data.standart.Effectiveness$Mean[1],
+ INB = NA,
+ Var.INB = NA,
+ Sd.INB = NA,
+ LL_IC95_INB = NA,
+ UL_IC95_INB = NA
+ )
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ inb <- (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1]) *
+ WTPVal - (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1])
+ var.inb <- ( WTPVal^2
+ ) * Data.alternative.Effectiveness$Variance[i] +
+ Data.alternative.Cost$Variance[i] -
+ 2 * WTPVal * ( Data.alternative.Cost$CovDcDe[i] )
+ alfa <- 0.05 # the significance
+
+ ans.line <- data.frame( Strategy = Data.alternative.Cost$Treatment[i],
+ Cost = Data.alternative.Cost$Mean[i],
+ Incr.Cost = Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1],
+ Effectiveness = Data.alternative.Effectiveness$Mean[i],
+ Incr.Eff. = Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1],
+ CE.ratio = Data.alternative.Cost$Mean[i] / Data.alternative.Effectiveness$Mean[i],
+ INB = inb,
+ Var.INB = var.inb,
+ Sd.INB = var.inb^0.5,
+ LL_IC95_INB = inb - qnorm(1 - alfa/2) * var.inb^0.5,
+ UL_IC95_INB = inb + qnorm(1 - alfa/2) * var.inb^0.5
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+
+# print(ans)
+
+ displayInTable(as.matrix(ans), title="INB - Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(INBsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(Frame2,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(Frame2,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(INBsimtableWindow, "<Return>",OnOK)
+ tkbind(INBsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(INBsimtableWindow, 250, 230)
+
+ tkfocus(INBsimtableWindow)
+
+}
+
Property changes on: pkg/R/inb.sim.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/inbwindow.R
===================================================================
--- pkg/R/inbwindow.R (rev 0)
+++ pkg/R/inbwindow.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,855 @@
+`inbwindow` <-
+function(TheTree) {
+ require(abind)
+ require(gplots)
+
+ plotINBtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - INB"
+ tkwm.title(plotINBtableWindow,title)
+
+ # What plot?
+ frameOverall <- tkwidget(plotINBtableWindow, "labelframe", borderwidth = 0, relief = "groove",
+ labelanchor = "n")
+ frametext <- "Gráfico"
+ framePlot <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frametext <- "Propriedades"
+ frameProp <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(plotINBtableWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ # The data to plot
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ AllTreatCost <- Data.CEA$Mean.Cost
+ AllTreatEffectiveness <- Data.CEA$Mean.Effectiveness
+ AllTreatCE <- Data.CEA$Mean.Cost / Data.CEA$Mean.Effectiveness
+
+ # Initial WTP
+ WTParray <- seq(0, 10000, round( (10000 - 0 ) / 10) )
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(Data.CEA$Node.name)
+ # The treatments names
+ treatments.label.plot <- Data.CEA$Node.name
+
+ # Default img type
+ img.type <- "png"
+ img.quality <- 90
+
+ # The frame Properties
+ LIvar <- tclVar(0)
+ LSvar <- tclVar(10000)
+ NPvar <- tclVar(10)
+
+ label0 <- tklabel(frameProp,text = "Intervalo para o WTP (threshold)")
+ tkgrid(label0, columnspan = 2, stick = "n")
+
+ entry.ValueLI <- tkentry(frameProp,width="20",textvariable=LIvar)
+ label1 <- tklabel(frameProp,text="Limite inferior")
+ tkgrid(label1, entry.ValueLI, sticky = "n")
+
+ entry.ValueLS <- tkentry(frameProp,width="20",textvariable=LSvar)
+ label2 <- tklabel(frameProp,text="Limite superior")
+ tkgrid(label2, entry.ValueLS, sticky = "n")
+
+ entry.ValueNP <- tkentry(frameProp,width="20",textvariable=NPvar)
+ label3 <- tklabel(frameProp,text="Intervalos")
+ tkgrid(label3, entry.ValueNP, sticky = "n")
+
+ # Cria o label
+ textlabellista <- "\nSelecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais.\n"
+ rotulolista <- tklabel(frameProp, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(frameProp, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA$Node.name
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(frameProp, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+
+ # ---------------------------------------------------------------------------------------------------
+ tkgrid(framePlot, frameProp, sticky = "n")
+ tkgrid(frameOverall, sticky = "nwe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(framePlot, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(framePlot, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(framePlot, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvoreCE.png", sep="")
+
+
+ plot.it.to.image <- function(wtp, cedata, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 400, img.height = 400, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "transparent")
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "transparent")
+
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "transparent")
+
+ dev.off()
+ }
+ }
+ }
+
+ build.cedata <- function() {
+ # The CEDATA
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = as.character(Data.standart$Node.name),
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = as.character(Data.alternative$Node.name[i]),
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+ ans$Strategy <- as.character(ans$Strategy)
+ return(ans)
+ }
+ # The CEDATA
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = as.character(Data.standart$Node.name),
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = as.character(Data.alternative$Node.name[i]),
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+ ans$Strategy <- as.character(ans$Strategy)
+
+ # end CEDATA
+
+ plot.it.to.image(WTParray, ans, treatments.colors.plot, treatments.label.plot = ans$Strategy,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+ OnExportGraphic <- function() {
+
+ LIVal <- as.numeric(tclvalue(LIvar))
+# print(LIVal)
+ LSVal <- as.numeric(tclvalue(LSvar))
+# print(LSVal)
+ NPVal <- as.numeric(tclvalue(NPvar))
+# print(NPVal)
+
+ do.it <- TRUE
+ if ( !(is.numeric(LIVal)) || (is.na(LIVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite inferior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(LSVal)) || (is.na(LSVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite superior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !do.it && ( LIVal > LSVal )) {
+ do.it <- FALSE
+ msg <- paste("O limite inferior deve ser menor que o limite superior.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(NPVal)) || (is.na(NPVal)) || (NPVal < 2) ) {
+ do.it <- FALSE
+ NPVal <- as.integer(NPVal)
+ msg <- paste("O valor fornecido para o número de intervalos não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+
+ if (do.it) {
+ file.remove(.Filename)
+ WTParray <- seq(LIVal, LSVal, round( (LSVal - LIVal ) / NPVal))
+
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ cedata <- as.data.frame(ans)
+ # print(ans)
+
+ cedata$Incr.Cost <- as.numeric(as.character(cedata$Incr.Cost))
+ cedata$Incr.Eff <- as.numeric(as.character(cedata$Incr.Eff))
+ cedata$Strategy <- as.character(cedata$Strategy)
+
+# print(cedata)
+
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ framePlot <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(framePlot, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(framePlot, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ ### Image size settings ###
+ numericSpinBox <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Altura da imagem")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", g.imgHeight,sep = ""))
+
+ numericSpinBox2 <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Largura da imagem")
+ tkgrid(labeldigits, numericSpinBox2, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox2, "setvalue", paste("@", g.imgWidth,sep = ""))
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ img.height <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(img.height) )&&(!is.na(img.height))) g.imgHeight <- img.height
+
+ img.width <- as.numeric(tclvalue(tcl(numericSpinBox2,"getvalue")))
+ if ((is.numeric(img.width) )&&(!is.na(img.width))) g.imgWidth <- img.width
+
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(WTParray, cedata, treatments.colors.plot, treatments.label.plot = cedata$Strategy,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(WTParray, cedata, treatments.colors.plot, treatments.label.plot = cedata$Strategy,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(WTParray, cedata, treatments.colors.plot, treatments.label.plot = cedata$Strategy,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotINBtableWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotINBtableWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(framePlot)
+ tkfocus(exportImgGraphWindow)
+ # posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+ }
+
+ Build.INB <- function(wtp, cedata, to.export = FALSE) {
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+
+ inb <- t(inb)
+ inb <- cbind(wtp, inb)
+ if (to.export) {
+ inb <- as.data.frame(inb)
+# print(c("WTP", as.character(cedata$Strategy)))
+ names(inb) <- c("WTP", as.character(cedata$Strategy))
+ } else {
+ colnames(inb) <- c("WTP", cedata$Strategy)
+ }
+# print(inb)
+
+ }
+
+ OnExportText <- function() {
+ LIVal <- as.numeric(tclvalue(LIvar))
+# print(LIVal)
+ LSVal <- as.numeric(tclvalue(LSvar))
+# print(LSVal)
+ NPVal <- as.numeric(tclvalue(NPvar))
+# print(NPVal)
+
+ do.it <- TRUE
+ if ( !(is.numeric(LIVal)) || (is.na(LIVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite inferior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(LSVal)) || (is.na(LSVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite superior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !do.it && ( LIVal > LSVal )) {
+ do.it <- FALSE
+ msg <- paste("O limite inferior deve ser menor que o limite superior.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(NPVal)) || (is.na(NPVal)) || (NPVal < 2) ) {
+ do.it <- FALSE
+ NPVal <- as.integer(NPVal)
+ msg <- paste("O valor fornecido para o número de intervalos não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+
+ if (do.it) {
+ file.remove(.Filename)
+ WTParray <- seq(LIVal, LSVal, round( (LSVal - LIVal ) / NPVal))
+
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+ ans$Strategy <- as.character(ans$Strategy)
+
+ inb <- ans$Incr.Eff[1] * WTParray - ans$Incr.Cost[1]
+ for (i in 2:dim(ans)[1]) {
+ balde.inb <- ans$Incr.Eff[i] * WTParray - ans$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- ans$Strategy
+ colnames(inb) <- paste("WTP = ", WTParray,sep = "")
+ Original.Dada <- inb
+
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(filetypeWindow)
+ else {
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(Original.Dada, file = fileName, row.names = TRUE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(Original.Dada, file = fileName, row.names = TRUE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ tkfocus(plotINBtableWindow)
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+ }
+
+ OnOKINB <- function() {
+
+ LIVal <- as.numeric(tclvalue(LIvar))
+# print(LIVal)
+ LSVal <- as.numeric(tclvalue(LSvar))
+# print(LSVal)
+ NPVal <- as.numeric(tclvalue(NPvar))
+# print(NPVal)
+
+ do.it <- TRUE
+ if ( !(is.numeric(LIVal)) || (is.na(LIVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite inferior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(LSVal)) || (is.na(LSVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite superior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !do.it && ( LIVal > LSVal )) {
+ do.it <- FALSE
+ msg <- paste("O limite inferior deve ser menor que o limite superior.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(NPVal)) || (is.na(NPVal)) || (NPVal < 2) ) {
+ do.it <- FALSE
+ NPVal <- as.integer(NPVal)
+ msg <- paste("O valor fornecido para o número de intervalos não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+
+ if (do.it) {
+ file.remove(.Filename)
+ WTParray <- seq(LIVal, LSVal, round( (LSVal - LIVal ) / NPVal))
+
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+ ans$Strategy <- as.character(ans$Strategy)
+
+# INB <- ans$Incr.Eff * WTParray - Incr.Cost
+
+ plot.it.to.image(WTParray, ans, treatments.colors.plot, treatments.label.plot = ans$Strategy,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+ }
+
+ }
+
+ OnCancel <- function() {
+ tkdestroy(plotINBtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ tkgrid(frameButton, sticky = "swe")
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.WTP.but <- tkbutton(frameProp,text="OK", width=.Width.but, height=.Height.but, command=OnOKINB)
+ tkgrid(OK.WTP.but, sticky = "s", padx = 5, pady = 5, columnspan = 2)
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnCancel)
+ ExportText.but <- tkbutton(frameButton,text="Relatório", width=.Width.but, height=.Height.but, command = function() OnExportText() )
+ Export.but <- tkbutton(frameButton,text="Exportar", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, ExportText.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(plotINBtableWindow, "<Return>",OnOKINB)
+ tkbind(plotINBtableWindow, "<Escape>",OnCancel)
+
+# posiciona.janela.no.mouse(plotINBtableWindow, 300, 180)
+
+ tkfocus(plotINBtableWindow)
+
+}
+
Property changes on: pkg/R/inbwindow.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/load.file.arv.R
===================================================================
--- pkg/R/load.file.arv.R (rev 0)
+++ pkg/R/load.file.arv.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,26 @@
+`load.file.arv` <-
+function(...) {
+ if (.workstatus != "saved") {
+ ans <- tkmessageBox(message="Deseja salvar a árvore atual?",icon="question",type="yesnocancel",default="yes")
+ ans <- tclvalue(ans)
+ if (ans == "yes") {
+ save.file.arv()
+ }
+ }
+ fileName <- tclvalue(tkgetOpenFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ clearTreeTkArvore(TheTree)
+ load(fileName, envir = .EnvironmentArvoRe)
+ load(fileName)
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ }
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ titletext <- paste("ÁrvoRe - Janela Principal - [", fileName, "]", sep = "")
+ tkwm.title(tt, titletext)
+
+}
+
Property changes on: pkg/R/load.file.arv.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/markov.coort.table.R
===================================================================
--- pkg/R/markov.coort.table.R (rev 0)
+++ pkg/R/markov.coort.table.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,227 @@
+# FUNCTION :: markov.coort.table # Mar 05, 2008 03:32:43 PM
+# Use this function to do some thing. # Revision : June 28, 2008 09:54:12 PM
+#
+# Parameters
+# TheTree : structure tree dataframe.
+# markov.propertiesMAT : base nodes properties of Markov nodes.
+# markov.termination : stop simulation when FALSE.
+# initial.coort : initial coort size.
+# seed : seed used in RNG.
+# absorventstatedeath :
+#
+# Example
+# markov.coort.table( TheTree, "(.stage == 10)||(.total.reward >= 110000)" )
+#
+markov.coort.table <- function(TheTree, markov.propertiesMAT, markov.termination, initial.coort = 10000, seed = FALSE,
+ absorventstatedeath = 1) {
+
+ # ajusta a semente escolhida pelo usuário
+ if (seed != FALSE) {
+ set.seed(seed)
+ }
+
+ # Convert the tree to matrix format
+ MatrixTheTree <- convert2matrix(TheTree)
+ x <- MatrixTheTree$x # Structure matrix
+ y <- MatrixTheTree$y # Node name matrix
+ #~ typeMAT <- MatrixTheTree$typeMAT # Node type matrix
+ utilityMAT <- MatrixTheTree$utilityMAT # Node Cost matrix
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT # Node effectiveness matrix
+ probMAT <- MatrixTheTree$probMAT # Node probability matrix
+ destinyMAT <- MatrixTheTree$destinyMAT # Terminal node destiny matrix
+
+ num.col.x <- dim(x)[2]
+ num.lin.x <- dim(x)[1]
+
+ SummaryTreeTable <- subset(TheTree, Level == 2)
+ col.pos <- as.numeric(SummaryTreeTable$Level)
+ MARKOV.states <- as.numeric(SummaryTreeTable$Node.N) # MARKOV.states
+ MARKOV.states.init.prob <- as.numeric(SummaryTreeTable$Prob) # MARKOV.states
+ MARKOV.states.init.cost.rwd <- as.numeric(markov.propertiesMAT$Initial.cost) # MARKOV.states
+ MARKOV.states.incr.cost.rwd <- as.numeric(markov.propertiesMAT$Incremental.cost) # MARKOV.states
+ MARKOV.states.final.cost.rwd <- as.numeric(markov.propertiesMAT$Final.cost) # MARKOV.states
+ MARKOV.states.init.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Initial.effectiveness) # MARKOV.states
+ MARKOV.states.incr.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Incremental.effectiveness) # MARKOV.states
+ MARKOV.states.final.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Final.effectiveness) # MARKOV.states
+
+ MARKOV.states.names <- SummaryTreeTable$Node.name
+
+ # Aplica desconto nas payoffs de quem não volta para a árvore associada.
+ MARKOV.discount.costs <- SummaryTreeTable$Payoff1
+ MARKOV.discount.effectiveness <- SummaryTreeTable$Payoff2
+
+ # listas para comportar matrizes associadas a cada Markov state
+ MARKOV.states.arvores <- list()
+ MARKOV.states.rotulos <- list()
+ MARKOV.states.destino <- list()
+ MARKOV.states.probs <- list()
+ MARKOV.states.costs <- list()
+ MARKOV.states.effectiveness <- list()
+
+ # fragmenta a matriz da árvore em sub-árvores associadas a cada Markov state
+ for (i in 1:length(MARKOV.states.names)) {
+ MARKOV.state <- MARKOV.states[i]
+ selected.lines <- which(x[,col.pos[i]] == MARKOV.state)
+
+ sub.x <- x[selected.lines, col.pos[i]:num.col.x]
+ sub.y <- y[selected.lines, col.pos[i]:num.col.x]
+ sub.probMAT <- probMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.utilityMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.effectivenessMAT <- effectivenessMAT[selected.lines, col.pos[i]:num.col.x]
+ #~ sub.typeMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.destiny <- destinyMAT[selected.lines]
+
+ # se a fragmentação resulta em matriz linha, então é preciso definir que isso é
+ # uma matriz... senão vira vetor e não funciona.
+ if(length(selected.lines) == 1) {
+ sub.x <- sub.x[!is.na(sub.x)]
+ n.mat <- length(sub.x) + 1
+ sub.x <- matrix(c(1, sub.x) , 1, n.mat)
+ sub.y <- matrix(sub.y[1], 1, n.mat)
+ sub.probMAT <- matrix(1.0, 1, n.mat)
+ sub.utilityMAT <- matrix(c(0,sub.utilityMAT), 1, n.mat)
+ sub.effectivenessMAT <- matrix(c(0,sub.effectivenessMAT), 1, n.mat)
+ #~ sub.typeMAT <- matrix(c("D",sub.typeMAT), 1, n.mat)
+ } else {
+ sub.probMAT[,1] <- 1.0 # Agora o nodo raiz recebe prob = 1.
+ }
+
+ # ajusta custo e efetividade: serão acumulados através dos nodos.
+ sub.utilityMAT <- apply(sub.utilityMAT, 1, sum)
+ sub.effectivenessMAT <- apply(sub.effectivenessMAT, 1, sum)
+
+ # abaixo se manda cada matriz de sub-árvore para suas listas.
+ MARKOV.states.arvores[[i]] <- sub.x
+ MARKOV.states.rotulos[[i]] <- sub.y
+ MARKOV.states.destino[[i]] <- sub.destiny
+ MARKOV.states.probs[[i]] <- sub.probMAT
+ MARKOV.states.costs[[i]] <- sub.utilityMAT
+ MARKOV.states.effectiveness[[i]] <- sub.effectivenessMAT
+ }
+
+ # ajusta nomes nas listas.
+ names(MARKOV.states.arvores) <- c(as.array(as.character(MARKOV.states)))
+ names(MARKOV.states.rotulos) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.destino) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.probs) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.costs) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.effectiveness) <- names(MARKOV.states.arvores)
+
+ # ajuste para quem não retorna à árvore associada
+ for (i in 1:length(MARKOV.states.names)) {
+ MARKOV.states.costs[[as.character(MARKOV.states[i])]] <- MARKOV.states.costs[[as.character(MARKOV.states[i])]] -
+ MARKOV.discount.costs[as.numeric(i)] +
+ MARKOV.discount.costs[as.numeric(MARKOV.states.destino[[as.character(MARKOV.states[i])]])]
+ MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]] <- MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]] -
+ MARKOV.discount.effectiveness[as.numeric(i)] +
+ MARKOV.discount.effectiveness[as.numeric(MARKOV.states.destino[[as.character(MARKOV.states[i])]])]
+ }
+
+ # Busca por estados absorventes
+ if (absorventstatedeath == 1) {
+ nodos.test.absorvent <- names(MARKOV.states.destino)
+ absorventstate <- array(,0)
+
+ for (i in nodos.test.absorvent) {
+ destinyofthisstate <- MARKOV.states.destino[[i]]
+ checkdestiny <- ( destinyofthisstate == i )
+ if ( sum(checkdestiny) == length(destinyofthisstate) ) {
+# cat("Ele é absorvente '", i, "' chamado '", MARKOV.states.rotulos[[i]][1,1],"'\n")
+ absorventstate <- c(absorventstate, i)
+ }
+ }
+ }
+
+ # cria a tabela que comportará os individuos
+ num.markov.states <- length(MARKOV.states)
+ Coorte.Ind <- matrix(MARKOV.states[num.markov.states],1,initial.coort) # Matriz com cada individuo
+ Coorte.Cost <- matrix(0,1,initial.coort) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(0,1,initial.coort) # Matriz com a efetividade de cada individuo
+
+ # sorteia a distribuição inicial
+ init.distr.Prob <- cumsum(MARKOV.states.init.prob)
+ sorteados <- runif(initial.coort,0,1)
+ if (num.markov.states > 1) {
+ for (i in (num.markov.states-1):1) {
+ positions <- which( sorteados <= init.distr.Prob[i] )
+ Coorte.Ind[1,positions] <- MARKOV.states[i]
+ Coorte.Cost[1,positions] <- MARKOV.states.init.cost.rwd[i]
+ Coorte.Effec[1,positions] <- MARKOV.states.init.effectiveness.rwd[i]
+ }
+ }
+
+ # control variables
+ .stop.sim <- TRUE
+ .stage <- 1
+ .stage.cost <- sum(Coorte.Cost)
+ .stage.eff <- sum(Coorte.Effec)
+ .stage.reward <- .stage.cost
+ .total.cost <- .stage.cost
+ .total.eff <- .stage.eff
+ .total.reward <- .stage.cost # ajusta a soma do ciclo zero para zero.
+
+ while( ! eval( parse(text = markov.termination) ) ) {
+ .stage <- .stage + 1
+ Coorte.Ind.LINE <- matrix(MARKOV.states[num.markov.states],1,initial.coort)
+ Coorte.Cost.LINE <- matrix(0,1,initial.coort)
+ Coorte.Effec.LINE <- matrix(0,1,initial.coort)
+
+ for (i in 1:num.markov.states ) {
+ positions <- which(Coorte.Ind[.stage - 1,] == MARKOV.states[i])
+ indvs <- length(positions)
+ if ( indvs != 0 ) {
+ arvore <- MARKOV.states.arvores[[as.character(MARKOV.states[i])]]
+ rotulos <- MARKOV.states.rotulos[[as.character(MARKOV.states[i])]]
+ destinos <- MARKOV.states.destino[[as.character(MARKOV.states[i])]]
+ probabilidades <- MARKOV.states.probs[[as.character(MARKOV.states[i])]]
+ custos <- MARKOV.states.costs[[as.character(MARKOV.states[i])]]
+ efetividades <- MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]]
+ sorteado <- runif(indvs,0,1)
+ linprobs <- cumsum(apply(probabilidades, 1, prod)) # observa a probabilidade de cada ramo acontecer numa runif
+ valn <- length(linprobs)
+ linprobs.Matrix <- matrix(linprobs, indvs, valn, byrow = TRUE) # podemos ter problema de memória aqui!!!
+ resultado <- valn - apply(sorteado <= linprobs.Matrix, 1, sum) + 1
+ ans.dest <- destinos[resultado] # quantos vão para cada categoria
+ ans.cost <- custos[resultado]
+ ans.effectiveness <- efetividades[resultado]
+ }
+ Coorte.Ind.LINE[1,positions] <- ans.dest
+ Coorte.Cost.LINE[1,positions] <- ans.cost
+ Coorte.Effec.LINE[1,positions] <- ans.effectiveness
+ }
+ .stage.cost <- sum(Coorte.Cost.LINE)
+ .stage.eff <- sum(Coorte.Effec.LINE)
+ .stage.reward <- .stage.cost
+ .total.cost <- .total.cost + .stage.cost
+ .total.eff <- .total.eff + .stage.eff
+ .total.reward <- .total.cost # ajusta a soma do ciclo zero para zero.
+
+ Coorte.Ind <- rbind(Coorte.Ind, Coorte.Ind.LINE)
+ Coorte.Cost <- rbind(Coorte.Cost, Coorte.Cost.LINE)
+ Coorte.Effec <- rbind(Coorte.Effec, Coorte.Effec.LINE)
+ }
+
+ # Definições para a soma de valores no final da simulação (the final reward)
+ for (i in num.markov.states:1) {
+ positions <- which( Coorte.Ind[.stage,] <= MARKOV.states[i] )
+ Coorte.Cost[.stage,positions] <- MARKOV.states.final.cost.rwd[i] + Coorte.Cost[.stage,positions]
+ Coorte.Effec[.stage,positions] <- MARKOV.states.final.effectiveness.rwd[i] + Coorte.Effec[.stage,positions]
+ }
+
+ # Aplica NA para individuos dos estados absorventes considerados morte
+ if (absorventstatedeath == 1) {
+ SurvivalCurve <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
+# Coorte.Ind <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
+# Coorte.Cost <- replace(Coorte.Cost, which( SurvivalCurve == NA), NA)
+ Coorte.Effec <- replace(Coorte.Effec, which( is.na(SurvivalCurve)), NA)
+ SurvivalCurve <- apply(!is.na(SurvivalCurve), 1, sum)
+ SurvivalCurve <- as.array(SurvivalCurve)
+ names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
+ } else {
+ SurvivalCurve <- rep( dim(Coorte.Ind)[2], dim(Coorte.Ind)[1])
+ names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
+ }
+
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec, Survival = SurvivalCurve)
+ return(ans) # And return the result
+}
Property changes on: pkg/R/markov.coort.table.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/markov.nodes.properties.R
===================================================================
--- pkg/R/markov.nodes.properties.R (rev 0)
+++ pkg/R/markov.nodes.properties.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,142 @@
+`markov.nodes.properties` <-
+function(TheTree, .EnvironmentArvoRe) {
+ exist.var <- exists("markov.propertiesMAT", envir = .EnvironmentArvoRe)
+ if (!exist.var) {
+ markov.propertiesMAT <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+ } else {
+ markov.propertiesMAT <- get("markov.propertiesMAT", .EnvironmentArvoRe)
+ }
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ position.father <- intersect(which((TheTree$Level == (column-1))),which(TheTree$Node.N == TheTree$Father[position]))
+
+ if ( (TheTree$Type[position.father] == "M") &&
+ ((TheTree$Type[position] == "T") || (TheTree$Type[position] == "C")) ) {
+ markovnodeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(markovnodeWindow,title)
+
+ position.markov <- intersect(which((markov.propertiesMAT$Level == column)),
+ which(markov.propertiesMAT$Node.N == node.number))
+
+ if ( length(position.markov) != 0) {
+ Initial.costvar <- tclVar(markov.propertiesMAT$Initial.cost[position.markov])
+ Incremental.costvar <- tclVar(markov.propertiesMAT$Incremental.cost[position.markov])
+ Final.costvar <- tclVar(markov.propertiesMAT$Final.cost[position.markov])
+ Initial.effectivenessvar <- tclVar(markov.propertiesMAT$Initial.effectiveness[position.markov])
+ Incremental.effectivenessvar <- tclVar(markov.propertiesMAT$Incremental.effectiveness[position.markov])
+ Final.effectivenessvar <- tclVar(markov.propertiesMAT$Final.effectiveness[position.markov])
+ } else {
+ Initial.costvar <- tclVar(0)
+ Incremental.costvar <- tclVar(0)
+ Final.costvar <- tclVar(0)
+ Initial.effectivenessvar <- tclVar(0)
+ Incremental.effectivenessvar <- tclVar(0)
+ Final.effectivenessvar <- tclVar(0)
+ }
+
+ entry.Value <- tkentry(markovnodeWindow,width="20",textvariable=Initial.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Inicial (ciclo zero)"), sticky = "nw")
+ tkgrid(entry.Value, sticky = "n")
+
+ entry.Value2 <- tkentry(markovnodeWindow,width="20",textvariable=Incremental.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Adicional (por ciclo)"), sticky = "nw")
+ tkgrid(entry.Value2, sticky = "n")
+
+ entry.Value3 <- tkentry(markovnodeWindow,width="20",textvariable=Final.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Final (após o final)"), sticky = "nw")
+ tkgrid(entry.Value3, sticky = "n")
+
+ entry.Value4 <- tkentry(markovnodeWindow,width="20",textvariable=Initial.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Inicial (ciclo zero)"), sticky = "nw")
+ tkgrid(entry.Value4, sticky = "n")
+
+ entry.Value5 <- tkentry(markovnodeWindow,width="20",textvariable=Incremental.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Adicional (por ciclo)"), sticky = "nw")
+ tkgrid(entry.Value5, sticky = "n")
+
+ entry.Value6 <- tkentry(markovnodeWindow,width="20",textvariable=Final.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Final (após o final)"), sticky = "nw")
+ tkgrid(entry.Value6, sticky = "n")
+
+ OnOK <- function()
+ {
+ Initial.costVal <- as.character(tclvalue(Initial.costvar))
+ Incremental.costVal <- as.character(tclvalue(Incremental.costvar))
+ Final.costVal <- as.character(tclvalue(Final.costvar))
+ Initial.effectivenessVal <- as.character(tclvalue(Initial.effectivenessvar))
+ Incremental.effectivenessVal <- as.character(tclvalue(Incremental.effectivenessvar))
+ Final.effectivenessVal <- as.character(tclvalue(Final.effectivenessvar))
+
+ if ( (!is.na(Initial.costVal)) && (nchar(Initial.costVal) > 0) &&
+ (!is.na(Incremental.costVal)) && (nchar(Incremental.costVal) > 0) &&
+ (!is.na(Final.costVal)) && (nchar(Final.costVal) > 0) &&
+ (!is.na(Initial.effectivenessVal)) && (nchar(Initial.effectivenessVal) > 0) &&
+ (!is.na(Incremental.effectivenessVal)) && (nchar(Incremental.effectivenessVal) > 0) &&
+ (!is.na(Final.effectivenessVal)) && (nchar(Final.effectivenessVal) > 0)
+ ) {
+ tkdestroy(markovnodeWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ set.markov.nodes.properties(TheTree, markov.propertiesMAT, column = column, node.number = node.number,
+ Initial.rwd.cost = Initial.costVal,
+ Incremental.rwd.cost = Incremental.costVal,
+ Final.rwd.cost = Final.costVal,
+ Initial.rwd.effectiveness = Initial.effectivenessVal,
+ Incremental.rwd.effectiveness = Incremental.effectivenessVal,
+ Final.rwd.effectiveness = Final.effectivenessVal)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Os valores definidos não são válidos.")
+ tkmessageBox(message = msg, icon="error", title = "ÁrvoRe - AVISO")
+ tkfocus(markovnodeWindow)
+ }
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but,text="OK",command=OnOK)
+ tkbind(markovnodeWindow, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(markovnodeWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancelar", command=OnCancel)
+
+ tkbind(markovnodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkfocus(markovnodeWindow)
+# posiciona.janela.no.mouse(markovnodeWindow, 230, 280)
+ } else {
+ msg <- paste("O nodo selecionado não é ramificação de um nodo Markov \n ou é de tipo inválido.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+
+}
+
Property changes on: pkg/R/markov.nodes.properties.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/naoimplementado.R
===================================================================
--- pkg/R/naoimplementado.R (rev 0)
+++ pkg/R/naoimplementado.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,8 @@
+`naoimplementado` <-
+function() {
+ require(tcltk)
+ Mensagem.txt <- "Esta funcionalidade não foi implementada ainda. Desculpe-nos."
+ tkmessageBox(message=Mensagem.txt, icon="warning", type="ok", title = "Markov - Custo Efetividade")
+ tkfocus(tt)
+}
+
Property changes on: pkg/R/naoimplementado.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/new.file.bot.R
===================================================================
--- pkg/R/new.file.bot.R (rev 0)
+++ pkg/R/new.file.bot.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,22 @@
+`new.file.bot` <-
+function(...) {
+ ans <- tkmessageBox(message="Deseja salvar a árvore atual?",icon="question",type="yesnocancel",default="yes")
+ ans <- tclvalue(ans)
+ if (ans != "yes") {
+ if (ans == "no") {
+ clearTreeTkArvore(TheTree)
+ new.tree()
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ } else {
+ tkfocus(tt)
+ }
+ } else {
+ save.file.arv()
+ clearTreeTkArvore(TheTree)
+ new.tree()
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ }
+}
+
Property changes on: pkg/R/new.file.bot.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/new.tree.R
===================================================================
--- pkg/R/new.tree.R (rev 0)
+++ pkg/R/new.tree.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,39 @@
+`new.tree` <-
+function() {
+ Payoffs <- matrix(0,1,2)
+
+ colnames(Payoffs) <- paste("Payoff",1:length(Payoffs),sep="")
+
+ TheTree <- data.frame( Level = 1, Node.N = 1, Node.name = "Decision",
+ Father = 0, Father.Name = "root",
+ Prob = 1, Type = "D", Note = " ", Destiny = " ",
+ Payoffs)
+
+ TheTree$Level <- as.numeric(TheTree$Level)
+ TheTree$Node.N <- as.numeric(TheTree$Node.N)
+ TheTree$Node.name <- as.character(TheTree$Node.name)
+ TheTree$Father <- as.numeric(TheTree$Father)
+ TheTree$Father.Name <- as.character(TheTree$Father.Name)
+ TheTree$Prob <- as.numeric(TheTree$Prob)
+ TheTree$Type <- as.character(TheTree$Type)
+ TheTree$Note <- as.character(TheTree$Note)
+ TheTree$Destiny <- as.character(TheTree$Destiny)
+ TheTree$Payoff1 <- as.numeric(TheTree$Payoff1)
+ TheTree$Payoff2 <- as.numeric(TheTree$Payoff2)
+
+ markov.propertiesMAT <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+
+ assign("TheTree", TheTree, .EnvironmentArvoRe)
+ assign("markov.propertiesMAT", markov.propertiesMAT, .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/new.tree.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/new.variable.list.R
===================================================================
--- pkg/R/new.variable.list.R (rev 0)
+++ pkg/R/new.variable.list.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+`new.variable.list` <-
+function() {
+ Variable <- array(" ",0)
+ StdValue <- array(0,0)
+ MinValue <- array(0,0)
+ MaxValue <- array(0,0)
+ Notes <- array(" ",0)
+
+ ans <- data.frame("Name" = Variable, "Fix.Value" = StdValue, "Min.Value" = MinValue,
+ "Max.Value" = MaxValue, "Notes" = Notes)
+ ans <- as.data.frame(ans)
+ assign("variableMAT", ans, .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/new.variable.list.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/nodenamewindows.R
===================================================================
--- pkg/R/nodenamewindows.R (rev 0)
+++ pkg/R/nodenamewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,54 @@
+`nodenamewindows` <-
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ nodenameWindow <- tktoplevel()
+ title <- "ÁrvoRe - Nome Nodo"
+ tkwm.title(nodenameWindow,title)
+
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ Namevar <- tclVar(TheTree$Node.name[position])
+
+ entry.Value <- tkentry(nodenameWindow,width="20",textvariable=Namevar)
+ tkgrid(tklabel(nodenameWindow,text="Nome do Nodo"), sticky = "n")
+ tkgrid(entry.Value, sticky = "n")
+ OnOK <- function()
+ {
+ NameVal <- as.character(tclvalue(Namevar))
+ if ( (is.character(NameVal)) && (!is.na(NameVal)) && (nchar(NameVal) > 0) ) {
+ tkdestroy(nodenameWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setnodename(TheTree, nodeSec[2], nodeSec[3], NameVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um nome de nodo válido '",NameVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(nodenameWindow)
+ }
+ }
+ OK.but <-tkbutton(nodenameWindow,text=" OK ",command=OnOK)
+ tkbind(entry.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(nodenameWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(nodenameWindow, text=" Cancelar ", command=OnCancel)
+ tkbind(nodenameWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkfocus(nodenameWindow)
+ posiciona.janela.no.mouse(nodenameWindow, 200, 100)
+ }
+}
+
Property changes on: pkg/R/nodenamewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/nodoselecionado.R
===================================================================
--- pkg/R/nodoselecionado.R (rev 0)
+++ pkg/R/nodoselecionado.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,19 @@
+`nodoselecionado` <-
+function() {
+ ans <- tclvalue(tcl(treeWidget,"selection","get"))
+ if ( ans == "") {
+ return(" ")
+ } else {
+ pos <- 1
+ while (pos <= nchar(ans)) {
+ if ( substr(ans, pos, pos) == "." ) {
+ ans.node <- substr(ans,1,pos-1)
+ ans.col <- substr(ans,pos+1,nchar(ans))
+ pos <- nchar(ans) + 1
+ }
+ pos <- pos + 1
+ }
+ return(c(ans,ans.node,ans.col))
+ }
+}
+
Property changes on: pkg/R/nodoselecionado.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/notesnodewindows.R
===================================================================
--- pkg/R/notesnodewindows.R (rev 0)
+++ pkg/R/notesnodewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,50 @@
+`notesnodewindows` <-
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+
+ notesWindow <- tktoplevel()
+ title <- "ÁrvoRe - Comentários do Nodo"
+ tkwm.title(notesWindow,title)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ Notesvar <- tclVar(TheTree$Note[position])
+ entry.Value <- tkentry(notesWindow, width="20", textvariable=Notesvar)
+ tkgrid(tklabel(notesWindow,text="Nota"))
+ tkgrid(entry.Value)
+
+ OnOK <- function()
+ {
+ NotesVal <- as.character(tclvalue(Notesvar))
+ tkdestroy(notesWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setnotesnode(TheTree, column = column, node.number = node.number, nodo.note = NotesVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ }
+ OK.but <-tkbutton(notesWindow, text=" OK ", command=OnOK)
+ tkbind(entry.Value, "<Return>", OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(notesWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(notesWindow, text=" Cancelar ", command=OnCancel)
+ tkbind(notesWindow, "<Escape>", OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(notesWindow, 200, 100)
+ tkfocus(notesWindow)
+ }
+}
+
Property changes on: pkg/R/notesnodewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/onGraph.summary.simwindow.R
===================================================================
--- pkg/R/onGraph.summary.simwindow.R (rev 0)
+++ pkg/R/onGraph.summary.simwindow.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,505 @@
+# FUNCTION :: onGraph.summary.simwindow # Criada em June 25, 2008 06:33:00 AM
+# Use this function to do something.
+#
+#
+# Revision : Xxxxxxxxxxx - Comentários.sobre.esta.revisão
+#
+#
+# Parameters
+# Xxxxxxx : xxxx.
+
+# Esta função faz alguma coisa
+onGraph.summary.simwindow <- function(Mktable, Alltreatmentstable, selected.treatment) {
+ # The data
+ Cost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ Effectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+
+ # The main window
+ graphsimulationWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Gráficos"
+ tkwm.title(graphsimulationWindow, title.window)
+
+ # Frames
+ frameOverall <- tkwidget(graphsimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+ frameResume <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove", text = "Tipos de Gráficos")
+ frameDistribution <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ text = "Distribuição")
+ frameOtherGraphs <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ text = "Custo-Efetividade")
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth = 0)
+
+
+ OnShowIt <- function(type = "Other", SurvivalData = Mktable$Survival,...) {
+
+ aGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Gráficos"
+ tkwm.title(aGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(aGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(aGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 480
+ g.imgWidth <- 640
+
+ # Canvas window configurations
+ C.Height <- g.imgHeight
+ C.Width <- g.imgWidth
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # What plot?
+ plot.it.to.image <- function(.Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, SurvivalData = Mktable$Survival,
+ ...) {
+
+ if( type == "Distrib.cost") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Distrib.effectiveness") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ #~ Effectiveness <- Effectiveness[!is.na(Effectiveness)]
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "CE.scatterplot") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Distrib.CER") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Survival.Curve") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+# hist(SurvivalData, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+ # hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+ # hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(aGraphWindow)
+ tkwm.deiconify(graphsimulationWindow)
+ tkfocus(graphsimulationWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+# tkconfigure(Export.but, state = "disabled")
+
+ tkbind(aGraphWindow, "<Return>", OnOK)
+ tkbind(aGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+
+ }
+
+ OnOK <- function() {
+ tkdestroy(graphsimulationWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(graphsimulationWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ OnDistrib.cost <- function() {
+ OnShowIt(type = "Distrib.cost")
+ }
+
+ OnDistrib.effectiveness <- function() {
+ OnShowIt(type = "Distrib.effectiveness")
+ }
+
+ OnDistrib.CER <- function() {
+ OnShowIt(type = "Distrib.CER")
+ }
+
+ OnDistrib.incrementals <- function() {
+ OnShowIt(type = "Distrib.incrementals")
+ }
+
+ OnCE <- function(Alltreatmentstable) {
+ OnCE.Graph.summary.simwindow(Alltreatmentstable)
+ }
+
+ OnCE.scatterplot <- function() {
+ OnShowIt(type = "CE.scatterplot")
+ }
+
+ OnAccept.Curve <- function(Alltreatmentstable) {
+ aceptability.sim.window(Alltreatmentstable)
+ }
+
+ OnSurvival.Curve <- function() {
+ SurvivalData <- Mktable$Survival
+ OnShowIt(type = "Survival.Curve", SurvivalData = SurvivalData)
+ }
+
+
+ # Button label
+ label.but1 <- "Custo"
+ label.but2 <- "Efetividade"
+ label.but3 <- "Razão Custo-Efetividade"
+ label.but4 <- "Incrementals"
+ label.but5 <- "Custo-Efetividade"
+ label.but6 <- "Scatterplot C-E"
+ label.but7 <- "Curva de aceitabilidade"
+ label.but8 <- "Curva de sobrevivência"
+
+ .Width.but <- max( c( nchar(label.but1), nchar(label.but2), nchar(label.but3), nchar(label.but4),
+ nchar(label.but5), nchar(label.but6), nchar(label.but7)) )
+ .Height.but <- 1
+
+ # The buttons
+ Distrib.cost.but <- tkbutton(frameDistribution, text = label.but1,
+ width=.Width.but, height=.Height.but, command = OnDistrib.cost)
+ Distrib.effectiveness.but <- tkbutton(frameDistribution,text = label.but2,
+ width=.Width.but, height=.Height.but, command = OnDistrib.effectiveness)
+ Distrib.CER.but <- tkbutton(frameDistribution,text = label.but3,
+ width =.Width.but, height=.Height.but, command = OnDistrib.CER)
+ Distrib.incrementals.but <- tkbutton(frameDistribution, text = label.but4,
+ width=.Width.but, height=.Height.but, command = OnDistrib.incrementals)
+ CE.but <- tkbutton(frameOtherGraphs, text = label.but5,
+ width=.Width.but, height=.Height.but, command = function() OnCE.Graph.summary.simwindow(Alltreatmentstable))
+ CE.scatterplot.but <- tkbutton(frameOtherGraphs,text=label.but6,
+ width=.Width.but, height=.Height.but, command = OnCE.scatterplot)
+ Accept.Curve.but <- tkbutton(frameOtherGraphs,text=label.but7,
+ width=.Width.but, height=.Height.but, command = function() OnAccept.Curve(Alltreatmentstable))
+ Survival.Curve.but <- tkbutton(frameOtherGraphs,text=label.but8,
+ width=.Width.but, height=.Height.but, command = OnSurvival.Curve)
+
+ tkgrid(Distrib.cost.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.effectiveness.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.CER.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.incrementals.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.scatterplot.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Accept.Curve.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Survival.Curve.but, sticky = "s", padx = 5, pady = 5)
+
+ OK.but <- tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <- tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameDistribution,sticky="nwe")
+ tkgrid(frameOtherGraphs,sticky="nwe")
+ tkgrid(frameResume,sticky="nwe")
+ tkgrid(frameLower, sticky = "s")
+ tkgrid(frameOverall)
+
+ tkbind(graphsimulationWindow, "<Return>", OnOK)
+ tkbind(graphsimulationWindow, "<Escape>", OnCancel)
+
+ tkfocus(graphsimulationWindow)
+
+}
\ No newline at end of file
Property changes on: pkg/R/onGraph.summary.simwindow.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/planoacewindow.R
===================================================================
--- pkg/R/planoacewindow.R (rev 0)
+++ pkg/R/planoacewindow.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,322 @@
+`planoacewindow` <-
+function(TheTree) {
+ require(abind)
+ require(gplots)
+
+ plotCEtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(plotCEtableWindow,title)
+
+ # What plot?
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(plotCEtableWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(plotCEtableWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 480
+ g.imgWidth <- 640
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvoreCE.png", sep="")
+
+ # The data to plot
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ AllTreatCost <- Data.CEA$Mean.Cost
+# print(AllTreatCost)
+ AllTreatEffectiveness <- Data.CEA$Mean.Effectiveness
+# print(AllTreatEffectiveness)
+ AllTreatCE <- Data.CEA$Mean.Cost / Data.CEA$Mean.Effectiveness
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(Data.CEA$Node.name)
+ # The treatments names
+ treatments.label.plot <- Data.CEA$Node.name
+
+ # Default img type
+ img.type <- "png"
+ img.quality <- 90
+
+ plot.it.to.image <- function(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ smartlegend( x="center", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ smartlegend( x="center", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost),
+ col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ for (i in 1:length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ smartlegend( x="center", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ dev.off()
+ }
+ }
+ }
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ ### Image size settings ###
+ numericSpinBox <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Altura da imagem")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", g.imgHeight,sep = ""))
+
+ numericSpinBox2 <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Largura da imagem")
+ tkgrid(labeldigits, numericSpinBox2, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox2, "setvalue", paste("@", g.imgWidth,sep = ""))
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ img.height <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(img.height) )&&(!is.na(img.height))) g.imgHeight <- img.height
+
+ img.width <- as.numeric(tclvalue(tcl(numericSpinBox2,"getvalue")))
+ if ((is.numeric(img.width) )&&(!is.na(img.width))) g.imgWidth <- img.width
+
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotCEtableWindow)
+ tkfocus(plotCEtableWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotCEtableWindow)
+ tkfocus(plotCEtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(plotCEtableWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(plotCEtableWindow)
+ file.remove(.Filename)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <- tkbutton(frameButton,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ Export.but <- tkbutton(frameButton,text="Exportar", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Cancel.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(plotCEtableWindow, "<Return>",OnOK)
+ tkbind(plotCEtableWindow, "<Escape>",OnOK)
+
+# posiciona.janela.no.mouse(plotCEtableWindow, 300, 180)
+
+ tkfocus(plotCEtableWindow)
+
+}
+
Property changes on: pkg/R/planoacewindow.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/plot.tree.R
===================================================================
--- pkg/R/plot.tree.R (rev 0)
+++ pkg/R/plot.tree.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,239 @@
+`plot.tree` <-
+function(TheTree, line.type = "squared", show.probability = TRUE,
+ show.payoffs = TRUE, show.notes = FALSE, node.name.font.size = 12,
+ payoffs.font.size = 0, notes.font.size = 0) {
+ require(grid)
+
+ MatrixTheTree <- convert2matrix(TheTree)
+ x <- MatrixTheTree$x
+ rotulos <- MatrixTheTree$y
+ typeMAT <- MatrixTheTree$typeMAT
+ utilityMAT <- MatrixTheTree$utilityMAT
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT
+ probMAT <- MatrixTheTree$probMAT
+ notesMAT <- MatrixTheTree$notesMAT
+
+ nc <- dim(x)[2]
+ nl <- dim(x)[1]
+
+ # Objetos
+ colorMAT <- matrix(0,nl,nc)
+ ylabelspace <- .021
+ colortext <- "black"
+ if (payoffs.font.size == 0) payoffs.font.size <- round(node.name.font.size/2,0)
+ if (notes.font.size == 0) notes.font.size <- round(node.name.font.size/2,0)
+
+ grid.newpage()
+
+ sizelabels <- matrix(0,nl,nc)
+ for (i in 1:nl) {
+ for (j in 1:nc) {
+ sizelabels[i,j] <- nchar(rotulos[i,j])
+ }
+ }
+
+ propcolx <- apply(sizelabels, 2, max)
+ propcolx <- cumsum(propcolx/2)
+
+ xpos <- NA*x
+ ypos <- NA*x
+ deltax <- 1 / ( max(propcolx) + 6 )
+
+ for( i in 1:nc) {
+ nniveis <- nl
+ niveis <- levels(as.factor(x[,i]))
+ deltay <- 1 / (nniveis + 1)
+ for (j in niveis) {
+ positions <- which(x[,i] == j)
+ ypos[positions, i] <- (nl - median(positions, na.rm = TRUE)) * deltay + deltay
+ }
+ xpos[,i] <- rep(1, nl) * deltax * propcolx[i]
+ }
+
+ if (nc > 1) {
+ if (line.type == "normal") {
+ for( i in 1:nl) {
+ for( j in 1:(nc-1)) {
+ linx <- c( xpos[i,j] , xpos[i,j+1] )
+ liny <- c( ypos[i,j] , ypos[i,j+1] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ }
+ } else {
+
+ for( i in 1:(nc-1)) { # plota as linhas verticais
+ nodos <- as.numeric(names(table(x[,i])))
+ for (j in nodos) {
+ positions <- which(x[,i] == j)
+ if ( (length(positions) >= 2) && (!is.na(x[positions[1],i+1])) ) {
+ linx <- c( xpos[positions[1],i] + (xpos[positions[1],i+1] - xpos[positions[1],i])/2 , xpos[positions[1],i] + (xpos[positions[1],i+1] - xpos[positions[1],i])/2 )
+ linymax <- max(ypos[positions,i+1], na.rm = TRUE)
+ linymin <- min(ypos[positions,i+1], na.rm = TRUE)
+ liny <- c(linymin,linymax)
+ grid.polyline( linx, liny )
+ }
+ }
+ }
+ for( i in 1:nl) { # plota as linhas horizontais
+ for( j in 1:(nc-1)) {
+ linx <- c( xpos[i,j] , xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2 )
+ liny <- c( ypos[i,j] , ypos[i,j] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ # plota linhas depois do nome para os nodos do último nível em uma dada "linha da matriz estrutura"
+ linx <- c( xpos[i,nc] , xpos[i,nc] + (xpos[i,nc] - xpos[i,nc-1])/2 )
+ liny <- c( ypos[i,nc] , ypos[i,nc] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ for( j in 2:nc) {
+ linx <- c( xpos[i,j-1] + (xpos[i,j] - xpos[i,j-1]) / 2, xpos[i,j] )
+ liny <- c( ypos[i,j] , ypos[i,j] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ }
+ }
+ }
+
+ # computa a matriz de cores
+ for( i in 1:nl) {
+ for (j in 1:nc) {
+ if ( (typeMAT[i,j] == "C")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "green"
+ else if ( (typeMAT[i,j] == "T")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "red"
+ else if ( (typeMAT[i,j] == "M")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "yellow"
+ else if ( (typeMAT[i,j] == "D")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "blue"
+ else colorMAT[i,j] <- "grey"
+ }
+ }
+
+ # plota grafico para o primeiro nodo
+ grid.text(rotulos[1,1], x = xpos[1,1],
+ y = ypos[1,1] + ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = node.name.font.size, col = colortext))
+
+ if (nc > 1) {
+ if ( line.type == "squared") {
+ grid.circle(x = xpos[1,1] + (xpos[1,2]-xpos[1,1])/2,
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ } else {
+ grid.circle(x = xpos[1,1],
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ }
+ for( i in 1:nl) {
+ for (j in 2:nc) {
+ d <- sum(is.na(c(xpos[i,j],ypos[i,j])))
+ if (d == 0) {
+ grid.text(rotulos[i,j], x = xpos[i,j] ,
+ y = ypos[i,j] + ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = node.name.font.size, col=colortext))
+ minortext <- as.character("")
+ if (show.probability) minortext <- paste("prob. ",probMAT[i,j], sep = "")
+ if (show.payoffs) {
+ minortext <- paste(minortext, "\n cost. ", utilityMAT[i,j], sep = "")
+ if (.modeltypeArvore == "CE") {
+ minortext <- paste(minortext, "\n effect. ", effectivenessMAT[i,j], sep = "")
+ }
+ }
+ grid.text(minortext,
+ x = xpos[i,j],
+ y = ypos[i,j] - 2 * ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = payoffs.font.size, col=colortext))
+ if (show.notes) {
+ nreptext <- sum(c(show.probability, show.payoffs, (.modeltypeArvore == "CE")))
+ minortext2 <- paste(rep("\n",nreptext), notesMAT[i,j], sep = "")
+ grid.text(minortext2,
+ x = xpos[i,j],
+ y = ypos[i,j] - 2 * ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = notes.font.size, col=colortext))
+ }
+ # Desenhos dos nodos - para o caso "normal" e "squared"
+ if ( line.type == "squared") {
+ if ( j != nc) {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2,
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ } else {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j] + (xpos[i,j] - xpos[i,j-1])/2,
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j] + (xpos[i,j] - xpos[i,j-1])/2
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ }
+ } else {
+ if ( j != nc) {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j],
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j]
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ } else {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j],
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j]
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ grid.circle(x = xpos[1,1] + (xpos[1,1])/2,
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ }
+
+}
+
Property changes on: pkg/R/plot.tree.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/posiciona.janela.centro.R
===================================================================
--- pkg/R/posiciona.janela.centro.R (rev 0)
+++ pkg/R/posiciona.janela.centro.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,35 @@
+`posiciona.janela.centro` <-
+function(janela.principal, janela.nova) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.principal) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.principal) ) )
+
+ wm.main.height <- as.integer( tclvalue( tkwinfo("height", janela.principal) ) )
+ wm.main.width <- as.integer( tclvalue( tkwinfo("width", janela.principal) ) )
+
+ wm.child.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ wm.child.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ wm.x <- as.integer( tclvalue( tkwinfo("x", janela.principal) ) )
+ wm.y <- as.integer( tclvalue( tkwinfo("y", janela.principal) ) )
+
+ new.wm.x <- wm.x + wm.main.width/2 - wm.child.width/2
+ new.wm.y <- wm.y + wm.main.height/2 - wm.child.height/2
+
+ new.wm.x <- round(new.wm.x)
+ new.wm.y <- round(new.wm.y)
+
+ limite.sup.x <- round( MAX.width - wm.child.width )
+ limite.inf.x <- round( wm.child.width )
+ limite.sup.y <- round( MAX.height - wm.child.height )
+ limite.sup.y <- round( wm.child.height )
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$%#$%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.child.width, "x", wm.child.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+}
+
Property changes on: pkg/R/posiciona.janela.centro.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/posiciona.janela.no.mouse.R
===================================================================
--- pkg/R/posiciona.janela.no.mouse.R (rev 0)
+++ pkg/R/posiciona.janela.no.mouse.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,29 @@
+`posiciona.janela.no.mouse` <-
+function(janela.nova, wm.width = -1, wm.height = -1) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.nova) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.nova) ) )
+
+ if (wm.height == -1) wm.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ if (wm.width == -1) wm.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ mouse.x.pos <- as.integer( tclvalue( tkwinfo("pointerx", janela.nova) ) )
+ mouse.y.pos <- as.integer( tclvalue( tkwinfo("pointery", janela.nova) ) )
+
+ new.wm.x <- round( mouse.x.pos - wm.width/2 )
+ new.wm.y <- round( mouse.y.pos - wm.height/2 )
+
+ limite.sup.x <- round( MAX.width - wm.width/2 )
+ limite.inf.x <- 0
+ limite.sup.y <- round( MAX.height - wm.height/2 )
+ limite.inf.y <- 0
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$%#$%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y < limite.inf.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.width, "x", wm.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+}
+
Property changes on: pkg/R/posiciona.janela.no.mouse.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/posiciona.janela.tela.R
===================================================================
--- pkg/R/posiciona.janela.tela.R (rev 0)
+++ pkg/R/posiciona.janela.tela.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,26 @@
+`posiciona.janela.tela` <-
+function(janela.nova) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.nova) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.nova) ) )
+
+ wm.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ wm.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ new.wm.y <- round( MAX.height/2 - wm.height/2 )
+ new.wm.x <- round( MAX.width/2 - wm.width/2 )
+
+ limite.sup.x <- round( MAX.width - wm.width )
+ limite.inf.x <- 0
+ limite.sup.y <- round( MAX.height - wm.height )
+ limite.inf.y <- 0
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$%#$%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y < limite.inf.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.width, "x", wm.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+}
+
Property changes on: pkg/R/posiciona.janela.tela.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/probString2Numeric.R
===================================================================
--- pkg/R/probString2Numeric.R (rev 0)
+++ pkg/R/probString2Numeric.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,15 @@
+`probString2Numeric` <-
+function(probMAT) {
+ n.lin <- dim(probMAT)[1]
+ n.col <- dim(probMAT)[2]
+
+ ans <- matrix(, n.lin, n.col)
+
+ for (i in 1:n.lin) {
+ for (j in 1:n.col) {
+ ans[i,j] <- exec.text(probMAT[i,j])
+ }
+ }
+ return(ans)
+}
+
Property changes on: pkg/R/probString2Numeric.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/probability.check.R
===================================================================
--- pkg/R/probability.check.R (rev 0)
+++ pkg/R/probability.check.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,30 @@
+`probability.check` <-
+function(k) {
+ names(k) <- c("Level", "Node.N", "Node.name", "Father", "Father.Name",
+ "Prob", "Type", "Note", "Destiny", "Payoff1", "Payoff2")
+ Levels <- 2:max(k$Level)
+ variables <- names(k)
+
+ ans <- ""
+ for (i in Levels) {
+ Data <- subset(k, Level == i, select = variables)
+ nodes <- as.numeric(names(table(Data$Father)))
+ for (j in nodes) {
+ Data2 <- subset(Data, Father == j, select = variables)
+ psum <- sum(Data2$Prob)
+ if (psum != 1) {
+ nome.pai <- Data2$Father.Name[1]
+ ans <- paste(ans,
+ "Há problema em [ NÍVEL = ", i-1, ", NODO = ", nome.pai, " ] \n", sep = "")
+ }
+ }
+ }
+ ans2 <- "1"
+ if (nchar(ans) == 0) {
+ ans <- "As probabilidades somam 1. Tudo ok!"
+ ans2 <- "0"
+ }
+
+ return(c(ans,ans2))
+}
+
Property changes on: pkg/R/probability.check.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/probwindows.R
===================================================================
--- pkg/R/probwindows.R (rev 0)
+++ pkg/R/probwindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,52 @@
+`probwindows` <-
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ probWindow <- tktoplevel()
+ title <- "ÁrvoRe - Probabilidade Nodo"
+ tkwm.title(probWindow,title)
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ Probvar <- tclVar(TheTree$Prob[position])
+
+ entry.Value <- tkentry(probWindow,width="20",textvariable=Probvar)
+ tkgrid(tklabel(probWindow,text="Probabilidade"))
+ tkgrid(entry.Value)
+ OnOK <- function()
+ {
+ ProbVal <- as.numeric(tclvalue(Probvar))
+ if ( (is.numeric(ProbVal)) && (!is.na(ProbVal)) && (ProbVal <= 1) && (ProbVal >= 0) ) {
+ tkdestroy(probWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setprob(TheTree, nodeSec[2], nodeSec[3], ProbVal, .EnvironmentArvoRe)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor de probabilidade válido '",ProbVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(probWindow)
+ }
+ }
+ OK.but <-tkbutton(probWindow,text=" OK ",command=OnOK)
+ tkbind(entry.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(probWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(probWindow,text=" Cancelar ",command=OnCancel)
+ tkbind(probWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(probWindow, 200, 100)
+ tkfocus(probWindow)
+ }
+}
+
Property changes on: pkg/R/probwindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/properties.tree.R
===================================================================
--- pkg/R/properties.tree.R (rev 0)
+++ pkg/R/properties.tree.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,185 @@
+`properties.tree` <-
+function(...) {
+ propertiesWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(propertiesWindow,title)
+
+ tclRequire("BWidget")
+
+ frameOverall <- tkframe(propertiesWindow)
+ frameLeft <- tkframe(frameOverall)
+ frameRight <- tkframe(frameOverall)
+ titleframe <- "Método de Cálculo"
+ frameUpper <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Simulação 1-st order"
+ frameSimUpper <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Formato Numérico"
+ frameNumeric <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Formato da árvore"
+ frameTreePlot <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Exibir na árvore"
+ frameTreePlotElements <- tkwidget(frameRight, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+ titleframe <- "Fontes da árvore"
+ frameFontPlot <- tkwidget(frameRight, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+
+ ### Method settings ###
+ metodos <- c("Decisão simples (simple payoff)", "Custo-Efetividade")
+ method.arvore <- c("SD", "CE")
+
+ methodBox <- tkwidget(frameUpper, "ComboBox", editable=FALSE, values=metodos, width = 30)
+ labelmethodBox <- tklabel(frameUpper,text="Método")
+ tkgrid(labelmethodBox, methodBox, sticky = "nw", padx = 5, pady = 5)
+
+ if (.modeltypeArvore == "SD") {
+ selected.method <- "@0"
+ } else {
+ if (.modeltypeArvore == "CE") selected.method <- "@1"
+ }
+ tcl(methodBox, "setvalue", selected.method)
+
+ ### Numeric format settings ###
+ numericSpinBox <- tkwidget(frameNumeric, "SpinBox", editable=FALSE, range = c(0,10,1), width = 3)
+ labeldigits <- tklabel(frameNumeric,text="Número de casas decimais")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", .digits,sep = ""))
+
+ ### Simulation settings ###
+ absorventstatecb <- tkcheckbutton(frameSimUpper)
+ absorventstatecbValue <- tclVar(.absorventstateconf)
+ tkconfigure(absorventstatecb, variable = absorventstatecbValue)
+ tkgrid(absorventstatecb, tklabel(frameSimUpper,text = "Interpretar estado absorvente como morte"))
+
+ ### Tree Plot ###
+# ("squared", "normal")
+ tkgrid(tklabel(frameTreePlot,text="Ângulos das linhas das ramificação"), row = 0, column = 0, columnspan = 2, sticky = "w")
+
+ rb1 <- tkradiobutton(frameTreePlot)
+ tpValue <- tclVar(.treeangle)
+ tkconfigure(rb1, variable = tpValue, value = "squared")
+ tkgrid(rb1, row = 3, column = 0, sticky = "w")
+ tkgrid(tklabel( frameTreePlot,text="Retos"), row = 3, column = 1, sticky = "w")
+
+ rb2 <- tkradiobutton(frameTreePlot)
+ tkconfigure(rb2, variable = tpValue, value = "normal")
+ tkgrid(rb2, row = 4, column = 0, sticky = "w")
+ tkgrid(tklabel(frameTreePlot,text="Normais"), row = 4, column = 1, sticky = "w")
+
+ ### Tree Plot Elements ###
+# tkgrid(tklabel(frameTreePlotElements,text="Exibir na árvore"), row = 0, column = 0, columnspan = 2)
+
+ notescb <- tkcheckbutton(frameTreePlotElements)
+ notescbValue <- tclVar(.notesconf)
+ tkconfigure(notescb, variable = notescbValue)
+ tkgrid(notescb, tklabel(frameTreePlotElements,text="Comentários"))
+
+ probabilitycb <- tkcheckbutton(frameTreePlotElements)
+ probabilitycbValue <- tclVar(.probabilityconf)
+ tkconfigure(probabilitycb, variable = probabilitycbValue)
+ tkgrid(probabilitycb, tklabel(frameTreePlotElements,text="Probabilidades"))
+
+ payoffscb <- tkcheckbutton(frameTreePlotElements)
+ payoffscbValue <- tclVar(.payoffsconf)
+ tkconfigure(payoffscb, variable = payoffscbValue)
+ tkgrid(payoffscb, tklabel(frameTreePlotElements,text="Payoffs"))
+
+ tkgrid(frameUpper, sticky="nwe")
+ tkgrid(frameNumeric, sticky="nwe")
+ tkgrid(frameSimUpper, sticky="nwe")
+ tkgrid(frameTreePlot, sticky="nwe")
+ tkgrid(frameTreePlotElements, sticky="nwe")
+ tkgrid(frameFontPlot, sticky="nwe")
+
+ ### Tree Plot Font ###
+ font.nameSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Nome do nodo")
+ tkgrid(labeldigits, font.nameSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.nameSpinBox, "setvalue", paste("@", .node.name.font.size, sep = ""))
+
+ font.payoffsSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Payoffs (custo e efetividade)")
+ tkgrid(labeldigits, font.payoffsSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", .payoffs.font.size, sep = ""))
+
+ font.notesSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Comentários do nodo")
+ tkgrid(labeldigits, font.notesSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.notesSpinBox, "setvalue", paste("@", .notes.font.size, sep = ""))
+
+ # Configurações para o tamanho dos botões.
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OnDefault.font <- function () {
+ tcl(font.nameSpinBox, "setvalue", paste("@", 12, sep = ""))
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", 6, sep = ""))
+ tcl(font.notesSpinBox, "setvalue", paste("@", 6, sep = ""))
+ }
+
+ OnRestore.font <- function () {
+ tcl(font.nameSpinBox, "setvalue", paste("@", .node.name.font.size, sep = ""))
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", .payoffs.font.size, sep = ""))
+ tcl(font.notesSpinBox, "setvalue", paste("@", .notes.font.size, sep = ""))
+ }
+
+ Restore.font <-tkbutton(frameFontPlot,text="Restaurar", width=.Width.but, height=.Height.but, command=OnRestore.font)
+# tkgrid(Default.font, sticky = "sw", padx = 5, pady = 5)
+
+ Default.font <-tkbutton(frameFontPlot,text="Padrão", width=.Width.but, height=.Height.but, command=OnDefault.font)
+ tkgrid(Restore.font, Default.font, sticky = "sw", padx = 5, pady = 5)
+
+ OnOK <- function()
+ {
+ methodChoice <- method.arvore[as.numeric(tclvalue(tcl(methodBox,"getvalue")))+1]
+ assign(".modeltypeArvore", methodChoice, .EnvironmentArvoRe)
+
+ .digits <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(.digits) )&&(!is.na(.digits))) assign(".digits", .digits, .EnvironmentArvoRe)
+
+ .treeangle <- tclvalue(tpValue)
+ assign(".treeangle", .treeangle, .EnvironmentArvoRe)
+
+ .absorventstateconf <- as.numeric(as.character(tclvalue(absorventstatecbValue)))
+ assign(".absorventstateconf", .absorventstateconf, .EnvironmentArvoRe)
+
+ .notesconf <- as.numeric(as.character(tclvalue(notescbValue)))
+ assign(".notesconf", .notesconf, .EnvironmentArvoRe)
+
+ .probabilityconf <- as.numeric(as.character(tclvalue(probabilitycbValue)))
+ assign(".probabilityconf", .probabilityconf, .EnvironmentArvoRe)
+
+ .payoffsconf <- as.numeric(as.character(tclvalue(payoffscbValue)))
+ assign(".payoffsconf", .payoffsconf, .EnvironmentArvoRe)
+
+ .node.name.font.size <- as.numeric(tclvalue(tcl(font.nameSpinBox,"getvalue")))
+ if ((is.numeric(.node.name.font.size) )&&(!is.na(.node.name.font.size))) assign(".node.name.font.size", .node.name.font.size, .EnvironmentArvoRe)
+
+ .payoffs.font.size <- as.numeric(tclvalue(tcl(font.payoffsSpinBox,"getvalue")))
+ if ((is.numeric(.payoffs.font.size) )&&(!is.na(.payoffs.font.size))) assign(".payoffs.font.size", .payoffs.font.size, .EnvironmentArvoRe)
+
+ .notes.font.size <- as.numeric(tclvalue(tcl(font.notesSpinBox,"getvalue")))
+ if ((is.numeric(.notes.font.size) )&&(!is.na(.notes.font.size))) assign(".notes.font.size", .notes.font.size, .EnvironmentArvoRe)
+
+ tkdestroy(propertiesWindow)
+ refreshF5()
+ tkfocus(tt)
+ }
+ OnCancel <- function() {
+ tkdestroy(propertiesWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(propertiesWindow, "<Return>",OnOK)
+ tkbind(propertiesWindow, "<Escape>",OnCancel)
+
+ tkgrid(frameLeft, frameRight, ipadx = 6, sticky="nwe")
+ tkgrid(frameLower, sticky="nwe", columnspan = 2)
+ tkgrid(frameOverall)
+
+ tkfocus(propertiesWindow)
+}
+
Property changes on: pkg/R/properties.tree.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/refreshF5.R
===================================================================
--- pkg/R/refreshF5.R (rev 0)
+++ pkg/R/refreshF5.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,9 @@
+`refreshF5` <-
+function(...) {
+ clearTreeTkArvore(TheTree)
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ tcl(treeWidget,"opentree", "1.1") # Expande a árvore
+ settreevartype(TheTree) # para ajustar os tipos de variáveis no TheTree.
+}
+
Property changes on: pkg/R/refreshF5.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/remove.node.R
===================================================================
--- pkg/R/remove.node.R (rev 0)
+++ pkg/R/remove.node.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,83 @@
+`remove.node` <-
+function(TheTree, node.col, node.number) {
+ removelines <- select.subtree(TheTree, node.col, node.number, change.row.names = FALSE)
+ removelines <- rownames(removelines)
+
+ num.lin <- dim(TheTree)[1]
+
+ whoiwant <- as.numeric(setdiff(as.character(1:num.lin), removelines))
+
+ ans <- TheTree[whoiwant,]
+
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+
+ position <- which(ans$Level == 2)
+
+if( ( length(position) > 1 ) && ( dim(ans)[1] > 2 )) {
+ #- Correção para o primeiro do nível ---------------------------------------------------------------
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) != 1 ) &&
+ ( as.numeric(ans$Level[i]) > as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i]
+ ans$Node.N[i] <- 1
+ usedlevel <- ans$Level[i] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- ans$Node.N[i]
+ ans$Father.Name[position] <- ans$Node.name[i]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+
+ #- Correção para numeracao dos nodos -------------------------------------------------------------
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) > as.numeric(ans$Node.N[i-1])+1 ) &&
+ ( as.numeric(ans$Level[i]) == as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i]
+ ans$Node.N[i] <- ans$Node.N[i-1] + 1
+ usedlevel <- ans$Level[i-1] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- old.value
+ ans$Father.Name[position] <- ans$Node.name[i-1]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+ #--------------------------------------------------------------------------------------------------
+}
+ rownames(ans) <- NULL
+ return(ans)
+}
+
Property changes on: pkg/R/remove.node.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/removenodewindows.R
===================================================================
--- pkg/R/removenodewindows.R (rev 0)
+++ pkg/R/removenodewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,32 @@
+`removenodewindows` <-
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ node.col <- as.numeric(nodeSec[2])
+ if (node.col > 1) {
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ Removenamevar <- TheTree$Node.name[position]
+
+ msg <- paste("Deseja realmente excluir o nodo '", Removenamevar, "'?", sep = "")
+ ans <- tkmessageBox(message=msg, icon="question",type="yesnocancel",default="no")
+ ans <- as.character(tclvalue(ans))
+ if (ans == "yes") {
+ NewTheTree <- remove.node(TheTree, node.col, node.number)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setremovenode(NewTheTree, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ }
+ } else {
+ msg <- paste("Não é possível remover o nodo raiz.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+}
+
Property changes on: pkg/R/removenodewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/rollback.R
===================================================================
--- pkg/R/rollback.R (rev 0)
+++ pkg/R/rollback.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,53 @@
+`rollback` <-
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+
+ x <- Matrixset$x
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+
+ num.col <- dim(probMAT)[2]
+ num.lin <- dim(probMAT)[1]
+
+ ans.ce <- matrix(0, num.lin, num.col)
+ ans.cost <- matrix(0, num.lin, num.col)
+ ans.effectiveness <- matrix(0, num.lin, num.col)
+
+ for (i in 1:(num.col)) {
+ nodes <- as.numeric(names(table(x[,i])))
+ for (j in nodes) {
+ position <- which(x[,i] == j)
+ sub.x <- x[position, i:num.col]
+ lines.sub <- length(position)
+ column.sub <- num.col - i + 1
+ sub.x <- matrix(sub.x, lines.sub, column.sub)
+ sub.prob <- probMAT[position, i:num.col]
+ sub.prob <- matrix(sub.prob, lines.sub, column.sub)
+ sub.util <- utilityMAT[position, i:num.col]
+ sub.util <- matrix(sub.util, lines.sub, column.sub)
+ sub.effectiveness <- effectivenessMAT[position, i:num.col]
+ sub.effectiveness <- matrix(sub.effectiveness, lines.sub, column.sub)
+
+ if (is.null(sub.prob)) {
+ sub.prob[,1] <- 1
+ sub.util[,1] <- 0
+ sub.effectiveness[,1] <- 1
+ val.expected.ce <- sum ( apply(sub.prob, 1, prod) * apply(sub.util/sub.effectiveness, 1, sum) )
+ val.expected.cost <- sum ( apply(sub.prob, 1, prod) * apply(sub.util, 1, sum) )
+ val.expected.effectiveness <- sum ( apply(sub.prob, 1, prod) * apply(sub.effectiveness, 1, sum) )
+ } else {
+ sub.prob[,1] <- 1
+ val.expected <- sum ( apply(sub.prob,1,prod) * apply(sub.util/sub.effectiveness,1,sum) )
+ val.expected.cost <- sum ( apply(sub.prob, 1, prod) * apply(sub.util, 1, sum) )
+ val.expected.effectiveness <- sum ( apply(sub.prob, 1, prod) * apply(sub.effectiveness, 1, sum) )
+ }
+ ans.ce[position, i] <- val.expected
+ ans.cost[position, i] <- val.expected.cost
+ ans.effectiveness[position, i] <- val.expected.effectiveness
+ }
+ }
+ ans <- list("CE" = ans.ce, "Cost" = ans.cost, "Effectiveness" = ans.effectiveness)
+ return(ans)
+}
+
Property changes on: pkg/R/rollback.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/safedofunction.R
===================================================================
--- pkg/R/safedofunction.R (rev 0)
+++ pkg/R/safedofunction.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`safedofunction` <-
+function(TheTree, .EnvironmentArvoRe, .modeltypeArvore) {
+ assign("TheTree", TheTree, .EnvironmentArvore.Secure)
+ assign(".modeltypeArvore", .modeltypeArvore, .EnvironmentArvore.Secure)
+}
+
Property changes on: pkg/R/safedofunction.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/sair.R
===================================================================
--- pkg/R/sair.R (rev 0)
+++ pkg/R/sair.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,27 @@
+`sair` <-
+function() {
+ ReturnVal <- tkmessageBox(title = "Sair do Programa",
+ message = "Deseja realmente sair do programa?",
+ icon = "question", type = "yesnocancel", default = "no")
+ if (tclvalue(ReturnVal) == "yes") {
+ if (.workstatus == "saved") {
+ tkdestroy(tt)
+ } else {
+ ReturnVal <- tkmessageBox(title = "Sair do Programa", message="Deseja salvar a árvore atual?",
+ icon="question", type="yesnocancel", default="yes")
+ if (tclvalue(ReturnVal) == "yes") {
+ save.file.arv()
+ tkdestroy(tt)
+ } else {
+ tkdestroy(tt)
+ }
+ }
+ # clear all arvoRe objects
+ .final.objects <- objects(envir = .EnvironmentArvoRe, all.names = TRUE)
+ .init.objects <- get(".init.objects", .EnvironmentArvoRe)
+ toremove.objects <- setdiff(.final.objects, .init.objects)
+ rm(list = toremove.objects, envir = .EnvironmentArvoRe)
+ }
+ else tkfocus(tt)
+}
+
Property changes on: pkg/R/sair.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/save.as.file.arv.R
===================================================================
--- pkg/R/save.as.file.arv.R (rev 0)
+++ pkg/R/save.as.file.arv.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,17 @@
+`save.as.file.arv` <-
+function(...) {
+ fileName<-tclvalue(tkgetSaveFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( ans != ".arv" ) fileName <- paste(fileName, ".arv", sep="")
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+}
+
Property changes on: pkg/R/save.as.file.arv.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/save.file.arv.R
===================================================================
--- pkg/R/save.file.arv.R (rev 0)
+++ pkg/R/save.file.arv.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,27 @@
+`save.file.arv` <-
+function(...) {
+ if ( .opennedfile == "newfile") {
+ fileName <- tclvalue(tkgetSaveFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( ans != ".arv" ) fileName <- paste(fileName, ".arv", sep="")
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+ } else {
+ fileName <- .opennedfile
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+}
+
Property changes on: pkg/R/save.file.arv.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/select.markov.propertiesMAT.R
===================================================================
--- pkg/R/select.markov.propertiesMAT.R (rev 0)
+++ pkg/R/select.markov.propertiesMAT.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,64 @@
+`select.markov.propertiesMAT` <-
+function(TheTree, SubTree, markov.propertiesMAT) {
+ require(abind)
+
+ selected.lines <- rownames(SubTree)
+ check.tree <- TheTree[selected.lines,]
+ wanted.level <- check.tree$Level[1]+1
+ check.tree <- check.tree[check.tree$Level == wanted.level,]
+ ans <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+ for (i in 1:length(check.tree$Node.N) ) {
+ balde <- subset(markov.propertiesMAT, Node.N == check.tree$Node.N[i])
+ n.lin.balde <- dim(balde)[1]
+ if (n.lin.balde > 0) {
+ ans <- abind(ans, balde, along = 1)
+ } else {
+ balde <- data.frame( "Level" = check.tree$Level[i],
+ "Node.N" = check.tree$Node.N[i],
+ "Node.name" = check.tree$Node.name[i],
+ "Father" = check.tree$Father[i],
+ "Father.Name" = check.tree$Father.Name[i],
+ "Initial.cost" = 0,
+ "Incremental.cost" = check.tree$Payoff1[i],
+ "Final.cost" = 0,
+ "Initial.effectiveness" = 0,
+ "Incremental.effectiveness" = check.tree$Payoff2[i],
+ "Final.effectiveness" = 0)
+ ans <- abind(ans, balde, along = 1)
+ }
+ }
+ ans <- as.data.frame(ans)
+
+ wanted.level.sub <- SubTree$Level[1]+1
+ subSubTree <- subset(SubTree, Level == wanted.level.sub)
+ ans$Level <- subSubTree$Level
+ ans$Node.N <- subSubTree$Node.N
+ ans$Father <- subSubTree$Father
+ ans$Father.Name <- subSubTree$Father.Name
+ rownames(ans) <- rownames(subSubTree)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- (as.character(ans$Node.name))
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- (as.character(ans$Father.Name))
+ ans$Initial.cost <- as.numeric(as.character(ans$Initial.cost))
+ ans$Incremental.cost <- as.numeric(as.character(ans$Incremental.cost))
+ ans$Final.cost <- as.numeric(as.character(ans$Final.cost))
+ ans$Initial.effectiveness <- as.numeric(as.character(ans$Initial.effectiveness))
+ ans$Incremental.effectiveness <- as.numeric(as.character(ans$Incremental.effectiveness))
+ ans$Final.effectiveness <- as.numeric(as.character(ans$Final.effectiveness))
+
+ return(ans)
+}
+
Property changes on: pkg/R/select.markov.propertiesMAT.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/select.origins.R
===================================================================
--- pkg/R/select.origins.R (rev 0)
+++ pkg/R/select.origins.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,33 @@
+`select.origins` <-
+function(TheTree, node.col, node.number) {
+ require(abind)
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ ans <- TheTree[position,]
+
+ levelnodevalue <- node.col - 1
+ nodenumbervalue <- ans$Father[1] #[position]
+
+ while ( levelnodevalue > 0) {
+ position <- intersect(which((TheTree$Level == levelnodevalue)),which(TheTree$Node.N == nodenumbervalue))
+ subData <- TheTree[position,]
+ ans <- abind(subData, ans, along=1)
+ nodenumbervalue <- subData$Father[1]
+ levelnodevalue <- levelnodevalue - 1
+ }
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(ans$Level)
+ ans$Node.N <- as.numeric(ans$Node.N)
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(ans$Father)
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(ans$Prob)
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ return(ans)
+}
+
Property changes on: pkg/R/select.origins.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/select.subtree.R
===================================================================
--- pkg/R/select.subtree.R (rev 0)
+++ pkg/R/select.subtree.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,73 @@
+`select.subtree` <-
+function(TheTree, node.col, node.number, change.row.names = FALSE) {
+ require(abind)
+ levelmax <- max(TheTree$Level)
+ variables <- names(TheTree)
+
+ ans <- subset(TheTree, Level == node.col, select = variables)
+ ans <- subset(ans, Node.N == node.number, select = variables)
+# print(ans)
+
+ if (node.col != levelmax) {
+ i <- (node.col+1)
+ pais <- node.number
+ while (i != 0) {
+
+ Datatmp <- subset(TheTree, Level == i, select = variables)
+ novos.pais <- array(,0)
+ for (j in pais) {
+ DatatmpP <- subset(Datatmp, Father == j, select = variables)
+ if (dim(DatatmpP)[1] != 0) {
+ ans <- abind(ans, DatatmpP, along=1)
+# print(ans)
+ novos.pais <- c(novos.pais, DatatmpP$Node.N)
+ }
+ }
+ pais <- novos.pais
+
+ if (i == levelmax) {
+ i <- 0
+ } else {
+ i <- i + 1
+ }
+ if( length(pais) == 0) i <- 0
+ }
+ }
+
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(ans$Level)
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+#
+# # Ajusta a numeração dos nodos
+# levelmax <- max(ans$Level)
+# for (i in 1:levelmax) {
+# positions <- which(ans$Level == i)
+# n.node <- as.numeric(names(table(ans$Node.N[positions])))
+# size.n.node <- length(n.node)
+# for (j in 1:size.n.node) {
+# positions.node.replace <- which(ans$Node.N == n.node[j])
+# positions.node.replace <- intersect(positions, positions.node.replace)
+# ans$Node.N[positions.node.replace] <- j
+# if (i != levelmax) {
+# positions.next.level <- which(ans$Level == (i+1))
+# positions.node.as.father <- which(ans$Father == n.node[j])
+# positions.node.as.father <- intersect(positions.next.level, positions.node.as.father)
+# ans$Father[positions] <- j
+# }
+# }
+# }
+ ans <- ans[ order(ans$Level,ans$Node.N),]
+ if (change.row.names) rownames(ans) <- NULL
+ return(ans)
+}
+
Property changes on: pkg/R/select.subtree.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/set.markov.nodes.properties.R
===================================================================
--- pkg/R/set.markov.nodes.properties.R (rev 0)
+++ pkg/R/set.markov.nodes.properties.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,65 @@
+`set.markov.nodes.properties` <-
+function(TheTree, markov.propertiesMAT, column, node.number,
+ Initial.rwd.cost = 0,
+ Incremental.rwd.cost = 0,
+ Final.rwd.cost = 0,
+ Initial.rwd.effectiveness = 1,
+ Incremental.rwd.effectiveness = 1,
+ Final.rwd.effectiveness = 1 ) {
+
+ require(abind)
+
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position.markov <- intersect(which((markov.propertiesMAT$Level == column)),
+ which(markov.propertiesMAT$Node.N == node.number))
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ if (length(position.markov) != 0) {
+ markov.propertiesMAT$Node.name[position.markov] <- TheTree$Node.name[position]
+ markov.propertiesMAT$Father[position.markov] <- TheTree$Father[position]
+ markov.propertiesMAT$Father.Name[position.markov] <- TheTree$Father.Name[position]
+ markov.propertiesMAT$Initial.cost[position.markov] <- Initial.rwd.cost
+ markov.propertiesMAT$Incremental.cost[position.markov] <- Incremental.rwd.cost
+ markov.propertiesMAT$Final.cost[position.markov] <- Final.rwd.cost
+ markov.propertiesMAT$Initial.effectiveness[position.markov] <- Initial.rwd.effectiveness
+ markov.propertiesMAT$Incremental.effectiveness[position.markov] <- Incremental.rwd.effectiveness
+ markov.propertiesMAT$Final.effectiveness[position.markov] <- Final.rwd.effectiveness
+ } else {
+ markov.propertiesLINE <- data.frame("Level" = column,
+ "Node.N" = node.number,
+ "Node.name" = TheTree$Node.name[position],
+ "Father" = TheTree$Father[position],
+ "Father.Name" = TheTree$Father.Name[position],
+ "Initial.cost" = Initial.rwd.cost,
+ "Incremental.cost" = Incremental.rwd.cost,
+ "Final.cost" = Final.rwd.cost,
+ "Initial.effectiveness" = Initial.rwd.effectiveness,
+ "Incremental.effectiveness" = Incremental.rwd.effectiveness,
+ "Final.effectiveness" = Final.rwd.effectiveness)
+ markov.propertiesMAT <- abind(markov.propertiesMAT, markov.propertiesLINE, along=1)
+ markov.propertiesMAT <- as.data.frame(markov.propertiesMAT)
+
+ markov.propertiesMAT$Level <- as.numeric(as.character(markov.propertiesMAT$Level))
+ markov.propertiesMAT$Node.N <- as.numeric(as.character(markov.propertiesMAT$Node.N))
+ markov.propertiesMAT$Node.name <- (as.character(markov.propertiesMAT$Node.name))
+ markov.propertiesMAT$Father <- as.numeric(as.character(markov.propertiesMAT$Father))
+ markov.propertiesMAT$Father.Name <- (as.character(markov.propertiesMAT$Father.Name))
+ markov.propertiesMAT$Initial.cost <- as.numeric(as.character(markov.propertiesMAT$Initial.cost))
+ markov.propertiesMAT$Incremental.cost <- as.numeric(as.character(markov.propertiesMAT$Incremental.cost))
+ markov.propertiesMAT$Final.cost <- as.numeric(as.character(markov.propertiesMAT$Final.cost))
+ markov.propertiesMAT$Initial.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Initial.effectiveness))
+ markov.propertiesMAT$Incremental.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Incremental.effectiveness))
+ markov.propertiesMAT$Final.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Final.effectiveness))
+
+ }
+
+ setutility(TheTree, column, node.number, Incremental.rwd.cost, .EnvironmentArvoRe)
+ TheTree <- get("TheTree", .EnvironmentArvoRe)
+ seteffectiveness(TheTree, column, node.number, Incremental.rwd.effectiveness, .EnvironmentArvoRe)
+
+ assign("markov.propertiesMAT", markov.propertiesMAT, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/set.markov.nodes.properties.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/set.model.type.R
===================================================================
--- pkg/R/set.model.type.R (rev 0)
+++ pkg/R/set.model.type.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,12 @@
+`set.model.type` <-
+function(typemodel) {
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ if (( typemodel == "CE")||( typemodel == "SD")) {
+ assign(".modeltypeArvore", typemodel, .EnvironmentArvoRe)
+ } else {
+ cat("Error!! \n")
+ }
+ refreshF5()
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/set.model.type.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/set.value.R
===================================================================
--- pkg/R/set.value.R (rev 0)
+++ pkg/R/set.value.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,144 @@
+`set.value` <-
+function(TheTree) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ node.name <- TheTree$Node.name[position]
+
+ setvalueWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(setvalueWindow,title)
+
+ # Create frames
+ FrameOverall <- tkframe(setvalueWindow, borderwidth = 0, relief = "groove")
+ FrameLeft <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+ FrameRight <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+ FrameButton <- tkframe(FrameRight, borderwidth = 2, relief = "groove")
+ FrameMenuButton <- tkframe(FrameLeft, borderwidth = 2, relief = "groove")
+ FrameLower <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+
+ # Node label
+ text.to.label <- paste("Nodo : ", node.name, sep = "")
+ node.tk.label <- tklabel(FrameLeft, text = text.to.label)
+ if (node.type == "C") node.type.label <- "Chance"
+ else if (node.type == "T") node.type.label <- "Terminal"
+ else if (node.type == "M") node.type.label <- "Markov"
+ else if (node.type == "D") node.type.label <- "Decision"
+ else node.type.label <- "Unknow"
+
+ text.to.label <- paste("Tipo : ", node.type.label, sep = "")
+ node.tk.type <- tklabel(FrameLeft, text = text.to.label)
+
+ tkgrid(node.tk.label, sticky = "nw", columnspan = 2)
+ tkgrid(node.tk.type, sticky = "nw", columnspan = 2)
+
+ # The menubutton width
+ menubutton.width <- 15
+
+######### O menubutton
+ Operators <- tkmenubutton(FrameMenuButton, text = "Operadores", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuOperatorsChild <- tkmenu(Operators, tearoff=FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuOperatorsChild,"command",label=">",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="<",command=function() {})
+ tkadd(menuOperatorsChild,"command",label=">=",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="<=",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="==",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="&&",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="||",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="(",command=function() {})
+ tkadd(menuOperatorsChild,"command",label=")",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="Sair",command=function() tkdestroy(setvalueWindow))
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Operators, menu = menuOperatorsChild)
+ # Monta o rótulo e o checkbutton
+
+
+######### O menubutton
+ Functions <- tkmenubutton(FrameMenuButton, text = "Funções", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuFunctionsChild <- tkmenu(Functions, tearoff = FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuFunctionsChild,"command",label="X",command=function() {})
+ tkadd(menuFunctionsChild,"command",label="XX",command=function() {})
+ tkadd(menuFunctionsChild,"separator")
+ tkadd(menuFunctionsChild,"command",label="XXX",command=function() {})
+ tkadd(menuFunctionsChild,"command",label="XXXX",command=function() {})
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Functions, menu = menuFunctionsChild)
+
+######### O menubutton
+ Keywords <- tkmenubutton(FrameMenuButton, text = "Palavra chave", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuKeywordsChild <- tkmenu(Keywords, tearoff = FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuKeywordsChild,"command",label=".stage",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.cost",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.eff",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.reward",command=function() {})
+ tkadd(menuKeywordsChild,"separator")
+ tkadd(menuKeywordsChild,"command",label=".total.cost",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".total.eff",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".total.reward",command=function() {})
+ tkadd(menuKeywordsChild,"command",label="NONE",command=function() {})
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Keywords, menu = menuKeywordsChild)
+
+ # Monta os menubuttons
+ tkgrid(Operators, Functions, Keywords, sticky = "n", padx = 5, pady = 5)
+
+ Text.space <- tktext(FrameLeft, borderwidth = 2, relief = "sunken",
+ height = 5, width = 30, wrap = "word")
+
+
+
+ OnOK <- function()
+ {
+
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(setvalueWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(FrameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(FrameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkbind(setvalueWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(FrameButton, sticky = "nwe")
+ tkgrid(FrameMenuButton, sticky = "nwe")
+ tkgrid(Text.space, sticky = "swe", padx = 5, pady = 5)
+ tkgrid(FrameLeft, FrameRight, sticky = "nwe")
+ tkgrid(FrameLower, sticky = "swe")
+ tkgrid(FrameOverall)
+
+ tkfocus(setvalueWindow)
+ }
+}
+
Property changes on: pkg/R/set.value.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/set.zoom.image.tree.R
===================================================================
--- pkg/R/set.zoom.image.tree.R (rev 0)
+++ pkg/R/set.zoom.image.tree.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,8 @@
+`set.zoom.image.tree` <-
+function(imgHeight, imgWidth, scalarfac = 1) {
+ imgHeight <- imgHeight * scalarfac
+ imgWidth <- imgWidth * scalarfac
+ assign("imgHeight", imgHeight, .EnvironmentArvoRe)
+ assign("imgWidth", imgWidth, .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/set.zoom.image.tree.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setaddnode.R
===================================================================
--- pkg/R/setaddnode.R (rev 0)
+++ pkg/R/setaddnode.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`setaddnode` <-
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/setaddnode.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setdestinynode.R
===================================================================
--- pkg/R/setdestinynode.R (rev 0)
+++ pkg/R/setdestinynode.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`setdestinynode` <-
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/setdestinynode.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/seteffectiveness.R
===================================================================
--- pkg/R/seteffectiveness.R (rev 0)
+++ pkg/R/seteffectiveness.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+`seteffectiveness` <-
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Payoff2[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+
Property changes on: pkg/R/seteffectiveness.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setnodename.R
===================================================================
--- pkg/R/setnodename.R (rev 0)
+++ pkg/R/setnodename.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,21 @@
+`setnodename` <-
+function(TheTree, column, node.number, nodename, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+# old.father.name <- TheTree$Node.name[position]
+ TheTree$Node.name[position] <- nodename
+
+ position <- intersect(which((TheTree$Level == (column+1) )),which(TheTree$Father == node.number))
+
+ if (length(position) >= 1) {
+ TheTree$Father.Name[position] <- nodename
+ }
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+
Property changes on: pkg/R/setnodename.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setnotesnode.R
===================================================================
--- pkg/R/setnotesnode.R (rev 0)
+++ pkg/R/setnotesnode.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,11 @@
+`setnotesnode` <-
+function(TheTree, column, node.number, nodo.note, .EnvironmentArvoRe) {
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Note[position] <- nodo.note
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+
Property changes on: pkg/R/setnotesnode.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setprob.R
===================================================================
--- pkg/R/setprob.R (rev 0)
+++ pkg/R/setprob.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,15 @@
+`setprob` <-
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Prob[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ refreshF5()
+}
+
Property changes on: pkg/R/setprob.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setremovenode.R
===================================================================
--- pkg/R/setremovenode.R (rev 0)
+++ pkg/R/setremovenode.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,6 @@
+`setremovenode` <-
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/setremovenode.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/settreevartype.R
===================================================================
--- pkg/R/settreevartype.R (rev 0)
+++ pkg/R/settreevartype.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,16 @@
+`settreevartype` <-
+function(TheTree) {
+ TheTree$Level <- as.numeric(TheTree$Level)
+ TheTree$Node.N <- as.numeric(TheTree$Node.N)
+ TheTree$Node.name <- as.character(TheTree$Node.name)
+ TheTree$Father <- as.numeric(TheTree$Father)
+ TheTree$Father.Name <- as.character(TheTree$Father.Name)
+ TheTree$Prob <- as.numeric(TheTree$Prob)
+ TheTree$Type <- as.character(TheTree$Type)
+ TheTree$Note <- as.character(TheTree$Note)
+ TheTree$Destiny <- as.character(TheTree$Destiny)
+ TheTree$Payoff1 <- as.numeric(as.character(TheTree$Payoff1))
+ TheTree$Payoff2 <- as.numeric(as.character(TheTree$Payoff2))
+ assign("TheTree", TheTree, .EnvironmentArvoRe)
+}
+
Property changes on: pkg/R/settreevartype.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/settypenode.R
===================================================================
--- pkg/R/settypenode.R (rev 0)
+++ pkg/R/settypenode.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,11 @@
+`settypenode` <-
+function(TheTree, column, node.number, nodo.type, .EnvironmentArvoRe) {
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Type[position] <- nodo.type
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+
Property changes on: pkg/R/settypenode.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setutility.R
===================================================================
--- pkg/R/setutility.R (rev 0)
+++ pkg/R/setutility.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+`setutility` <-
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Payoff1[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+
Property changes on: pkg/R/setutility.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/setvariablelist.R
===================================================================
--- pkg/R/setvariablelist.R (rev 0)
+++ pkg/R/setvariablelist.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,29 @@
+`setvariablelist` <-
+function(variableMAT, newvariableline = " ", variable.name = " ", action = "edit") {
+ if (action == "delete") {
+ variables <- names(variableMAT)
+ ans <- subset(variableMAT, Name != variable.name, select = variables)
+ }
+ if (action == "add") {
+ require(abind)
+ ans <- abind(variableMAT, newvariableline, along=1)
+ }
+ if (action == "edit") {
+ variables <- names(variableMAT)
+ ans <- subset(variableMAT, Name != variable.name, select = variables)
+
+ require(abind)
+ ans <- abind(ans, newvariableline, along=1)
+ }
+
+ ans <- as.data.frame(ans)
+ ans$Name <- as.character(ans$Name)
+ ans$Fix.Value <- as.numeric(as.character(ans$Fix.Value))
+ ans$Min.Value <- as.numeric(as.character(ans$Min.Value))
+ ans$Max.Value <- as.numeric(as.character(ans$Max.Value))
+ ans$Notes <- as.character(ans$Notes)
+ assign("variableMAT", ans, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+
+}
+
Property changes on: pkg/R/setvariablelist.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/show.prob.check.window.R
===================================================================
--- pkg/R/show.prob.check.window.R (rev 0)
+++ pkg/R/show.prob.check.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,11 @@
+`show.prob.check.window` <-
+function(TheTree) {
+ msg <- probability.check(TheTree)
+ icon="error"
+ if (msg[2] == "0") {
+ icon="warning"
+ }
+ tkmessageBox(title = "ÁrvoRe - Verificação das Probabilidades", message=msg[1], icon = icon, type = "ok")
+ tkfocus(tt)
+}
+
Property changes on: pkg/R/show.prob.check.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/show.summary.rollback.window.R
===================================================================
--- pkg/R/show.summary.rollback.window.R (rev 0)
+++ pkg/R/show.summary.rollback.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,14 @@
+`show.summary.rollback.window` <-
+function(...) {
+ k <- summary.rollback.table(TheTree)
+
+ names(k) <- c("Nível", "Nodo N", "Nome do nodo",
+ "Custo Esperado", "Efetividade Esperada", "Razão C-E Esperada",
+ "Nome Nodo Pai", "Probabilidade",
+ "Custo", "Efetividade", "Tipo")
+
+ displayInTable(as.matrix(k), title="Valores Esperados (Roll-back)",
+ height=10,width=8,nrow=dim(k)[1],ncol=dim(k)[2],
+ titlerows = FALSE, titlecols = TRUE)
+}
+
Property changes on: pkg/R/show.summary.rollback.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/show.summary.tree.window.R
===================================================================
--- pkg/R/show.summary.tree.window.R (rev 0)
+++ pkg/R/show.summary.tree.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,9 @@
+`show.summary.tree.window` <-
+function(...) {
+ k <- TheTree
+
+ displayInTable(as.matrix(k), title="Informação da árvore",
+ height=10,width=8,nrow=dim(k)[1],ncol=dim(k)[2],
+ titlerows = FALSE, titlecols = TRUE)
+}
+
Property changes on: pkg/R/show.summary.tree.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/simple.markov.coort.table.R
===================================================================
--- pkg/R/simple.markov.coort.table.R (rev 0)
+++ pkg/R/simple.markov.coort.table.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,59 @@
+`simple.markov.coort.table` <-
+function(TheTree, trials = 10000, seed = FALSE) {
+ # ajusta a semente escolhida pelo usuário
+ if (seed != FALSE) {
+ set.seed(seed)
+ }
+
+ # Convert the tree to matrix format
+ MatrixTheTree <- convert2matrix(TheTree)
+# print(MatrixTheTree)
+ x <- MatrixTheTree$x # Structure matrix
+ y <- MatrixTheTree$y # Node name matrix
+ typeMAT <- MatrixTheTree$typeMAT # Node type matrix
+ utilityMAT <- MatrixTheTree$utilityMAT # Node Cost matrix
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT # Node effectiveness matrix
+ probMAT <- MatrixTheTree$probMAT # Node probability matrix
+
+ num.col.x <- dim(x)[2]
+ num.lin.x <- dim(x)[1]
+
+ probMAT[,1] <- 1.0 # Agora o nodo raiz recebe prob = 1.
+ typeMAT[,1] <- "D" # Agora o nodo raiz recebe "D".
+
+ # ajusta elementos para matriz... pois com vetor não funciona
+# utilityMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+# effectivenessMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+# probMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+
+ # ajusta custo e efetividade: serão acumulados através dos nodos.
+ if (num.lin.x > 1) {
+ utilityMAT <- apply(utilityMAT, 1, sum)
+ effectivenessMAT <- apply(effectivenessMAT, 1, sum)
+ } else {
+ utilityMAT <- sum(utilityMAT)
+ effectivenessMAT <- sum(effectivenessMAT)
+ }
+ # cria a tabela que comportará os individuos
+# Coorte.Ind <- matrix(0, 1, trials) # Matriz com cada individuo
+# Coorte.Cost <- matrix(0, 1, trials) # Matriz com custo de cada individuo
+# Coorte.Effec <- matrix(0, 1, trials) # Matriz com a efetividade de cada individuo
+
+ # A simulação em si. Choose your destiny!
+ sorteado <- runif(trials,0,1)
+ linprobs <- cumsum(apply(probMAT, 1, prod)) # observa a probabilidade de cada ramo acontecer numa runif
+ valn <- length(linprobs)
+ linprobs.Matrix <- matrix(linprobs, trials, valn, byrow = TRUE) # podemos ter problema de memória aqui!!!
+ resultado <- valn - apply(sorteado <= linprobs.Matrix, 1, sum) + 1
+# ans.dest <- destinos[resultado] # quantos vão para cada categoria
+ ans.cost <- utilityMAT[resultado]
+ ans.effectiveness <- effectivenessMAT[resultado]
+
+ Coorte.Ind <- matrix(resultado, 1, trials) # Matriz com cada individuo
+ Coorte.Cost <- matrix(ans.cost, 1, trials) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(ans.effectiveness, 1, trials) # Matriz com a efetividade de cada individuo
+
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec)
+ return(ans) # And return the result
+}
+
Property changes on: pkg/R/simple.markov.coort.table.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/sobre.R
===================================================================
--- pkg/R/sobre.R (rev 0)
+++ pkg/R/sobre.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,24 @@
+`sobre` <-
+function(versionarvore, versiondate) {
+ .Mensagem <- paste(
+" ________________________________________ \n\n",
+" ArvoRe - Análise de Custo Efetividade no R \n",
+" (Simulação de primeira ordem MCMC) \n\n",
+paste("Versão : ", versionarvore, " \n", sep=""),
+paste("Versão : ", versiondate, " \n", sep=""),
+" ________________________________________ \n\n",
+" Autor: \n",
+" Isaías V. Prestes \n",
+" IM - Departamento de Estatística \n",
+" Universidade Federal do Rio Grande do Sul, \n",
+" Av. Bento Gonçalves, 9500, Porto Alegre, Brasil \n",
+" E-mail: isaias.prestes at ufrgs.br \n",
+" URL: http://www.mat.ufrgs.br/~camey/ \n",
+" ________________________________________ \n",
+" \n", sep = "")
+ sobre.wm.title <- "Sobre o Programa"
+ ReturnVal <- tkmessageBox(title = sobre.wm.title,
+ message = .Mensagem, icon = "info", type = "ok")
+ tkfocus(tt)
+}
+
Property changes on: pkg/R/sobre.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/splashscreenArvoRe.R
===================================================================
--- pkg/R/splashscreenArvoRe.R (rev 0)
+++ pkg/R/splashscreenArvoRe.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,20 @@
+`splashscreenArvoRe` <-
+function() {
+ splashArvoRe <- tktoplevel()
+ Width <- 640
+ Height <- 480
+ tkwm.title(splashArvoRe, paste("ÁrvoRe - ", .arvore.version, sep=""))
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Arvore.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ new.but <- tkbutton(splashArvoRe, image=icn, width=Width, height=Height,
+ command=function() tkdestroy(splashArvoRe))
+ tkgrid(new.but)
+ }
+ }
+ posiciona.janela.tela(splashArvoRe)
+ tkfocus(splashArvoRe)
+ tcl("tkwait","window",splashArvoRe)
+}
+
Property changes on: pkg/R/splashscreenArvoRe.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/summary.rollback.table.R
===================================================================
--- pkg/R/summary.rollback.table.R (rev 0)
+++ pkg/R/summary.rollback.table.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,70 @@
+`summary.rollback.table` <-
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+ x <- Matrixset$x
+ y <- Matrixset$y
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+ typeMAT <- Matrixset$typeMAT
+
+ rollbackLIST <- rollback(TheTree)
+
+ num.col <- dim(x)[2]
+ num.lin <- dim(x)[1]
+
+ levelnode <- array(,0)
+ paispos <- array(,0)
+ nnode <- array(,0)
+ namenode <- array(,0)
+ probnode <- array(,0)
+ utilitynode <- array(,0)
+ effectivenessnode <- array(,0)
+ typenode <- array(,0)
+ paisnodos.n <- array(,0)
+ paisnodos.name <- array(,0)
+ paisnodos <- array(,0)
+ expectedvalue.cost <- array(,0)
+ expectedvalue.effectiveness <- array(,0)
+ expectedvalue.ce <- array(,0)
+
+ for (i in 1:num.col) {
+ max.node <- max(x[,i], na.rm = TRUE)
+ pais <- 1:max.node
+ for (k in pais) {
+ levelnode <- c(levelnode,i)
+ nodepos <- which(x[,i] == k)[1]
+ paispos <- c(paispos, nodepos)
+ if (i == 1) {
+ paisnodos.n <- c(paisnodos.n, 1)
+ paisnodos.name <- c(paisnodos.name, " ")
+ } else {
+ paisnodos.n <- c(paisnodos.n, x[nodepos, i-1])
+ paisnodos.name <- c(paisnodos.name, y[nodepos, i-1])
+ }
+ nnode <- c(nnode, k)
+ namenode <- c(namenode, y[nodepos, i])
+ probnode <- c(probnode, probMAT[nodepos, i])
+ utilitynode <- c(utilitynode, utilityMAT[nodepos, i])
+ effectivenessnode <- c(effectivenessnode, effectivenessMAT[nodepos, i])
+ typenode <- c(typenode, typeMAT[nodepos, i])
+ expectedvalue.cost <- c(expectedvalue.cost, rollbackLIST[["Cost"]][nodepos, i])
+ expectedvalue.effectiveness <- c(expectedvalue.effectiveness, rollbackLIST[["Effectiveness"]][nodepos, i])
+ expectedvalue.ce <- c(expectedvalue.ce, rollbackLIST[["CE"]][nodepos, i])
+
+ }
+ }
+
+ tabela <- data.frame(Level = levelnode, Node.N = nnode, Node.name = namenode,
+ "Mean Cost" = expectedvalue.cost,
+ "Mean Effectiveness" = expectedvalue.effectiveness,
+ "Mean C-E ratio" = expectedvalue.ce,
+# Father = paisnodos.n,
+ Father.Name = paisnodos.name,
+ Prob = probnode, Cost = utilitynode, Effectiveness = effectivenessnode,
+ Type = typenode
+ )
+
+ return(tabela)
+}
+
Property changes on: pkg/R/summary.rollback.table.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/summary.simulation.window.R
===================================================================
--- pkg/R/summary.simulation.window.R (rev 0)
+++ pkg/R/summary.simulation.window.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,945 @@
+`summary.simulation.window` <-
+function(Simlist, tempo1 = Sys.time(), tempo2 = Sys.time(), CicloVal, tipo.nodo = " ", digits = 3) {
+ require(abind)
+ require(gplots)
+
+ treatments.sim <- names(Simlist)
+
+ windheight <- 300
+ windwidth <- 750
+
+ summarysimulationWindow <- tktoplevel()
+ title <- "ÁrvoRe - Simulação Monte Carlo"
+ tkwm.title(summarysimulationWindow,title)
+
+ frameOverall <- tkwidget(summarysimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+ frameResume <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove")
+ framePanelButton <- tkwidget(frameResume, "labelframe", borderwidth = 0, relief = "groove")
+ framebutton <- tkwidget(summarysimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ pBar <- tkwidget(frameResume, "NoteBook", height = windheight, width = windwidth)
+
+ tkpack(frameOverall, expand = 1, fill = "both") #, side = "left")
+ tkpack(frameResume, expand = 1, fill = "both", side = "top", anchor = "ne")
+ tkpack(framebutton, expand = 1, fill = "x", side = "bottom")
+ tkpack(pBar, expand = 1, fill = "both", side = "left")
+ tkpack(framePanelButton, fill = "both", side = "right") # , anchor = "ne"
+
+ PageNoteBook <- tcl(pBar, "insert", "end", "Page0", "-text", "Nodos")
+
+ timecounter <- 1
+
+ Alltreatmentstable <- data.frame(Treatment = array(,0), Data = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0),Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0), CovDcDe = array(,0),
+ Time = array(,0))
+
+ for (i in treatments.sim) {
+
+ tempo <- tempo2[timecounter] - tempo1[timecounter]
+
+ timecounter <- timecounter + 1
+
+ # Cria uma página para este tratamento -------------------------------------------------
+ position <- which( treatments.sim == i)
+
+ pagetclname <- paste("Page",position, sep = "")
+ pagelabel <- i
+
+ PageNoteBook <- tcl(pBar, "insert", "end", pagetclname, "-text", pagelabel)
+ object.page.name <- paste("PageNoteBook", position, sep = "")
+ assign(object.page.name, PageNoteBook)
+
+ PageNoteBook.Window <- .Tk.newwin(PageNoteBook)
+ object.page.window.name <- paste("PageNoteBook.Window", position, sep = "")
+ assign(object.page.window.name, PageNoteBook.Window)
+
+ frameWindow <- tkwidget(PageNoteBook.Window, "labelframe", borderwidth = 2, relief = "groove", text = "Relatório")
+ # -------------------------------------------------
+
+ frameUpper <- tkframe(frameWindow, relief="groove", borderwidth = 0)
+ frameUpperLeft <- tkwidget(frameUpper, "labelframe", borderwidth = 2, relief = "groove", text = "Custo")
+ frameUpperRight <- tkwidget(frameUpper, "labelframe", borderwidth = 2, relief = "groove", text = "Efetividade")
+ frameLower <- tkframe(frameWindow, relief="groove", borderwidth=2)
+
+ # The node root name
+ node.root.name <- paste("Nodo : ", i, sep = "")
+ node.root.name.label <- tklabel(frameUpper, text = node.root.name)
+ tkgrid(node.root.name.label, sticky = "nw", columnspan = 1)
+
+ # The time of simulation
+ time.text <- paste("Tempo decorrido (segundos) : ", format(round(tempo, digits = digits), nsmall = digits), sep = "")
+ time.sim <- tklabel(frameUpper, text = time.text)
+ tkgrid(time.sim, sticky = "nw", columnspan = 1)
+
+
+ # A Efetividade -------------------------------------------------
+ Mktable <- Simlist[[i]]
+ Data <- Mktable$Effectiveness
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Data,2,sum, na.rm = TRUE)
+ ntreat <- length(Data)
+ statisticsData <- summary(Data, na.rm = TRUE)
+
+ meanData <- mean(Data)
+ if ( tipo.nodo[position] == "M") {
+ varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2)
+ } else {
+ varData <- var( Data, na.rm = TRUE )
+ }
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ DataEff <- Data
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "Effectiveness", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3,
+ CovDcDe = 0, Time = tempo)
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+# print(line.data.summary)
+# print(Alltreatmentstable)
+
+ Alltreatmentstable <- as.data.frame(Alltreatmentstable)
+ Alltreatmentstable$Treatment <- as.character(Alltreatmentstable$Treatment)
+ Alltreatmentstable$Data <- as.character(Alltreatmentstable$Data)
+ Alltreatmentstable$Mean <- as.numeric(as.character(Alltreatmentstable$Mean))
+ Alltreatmentstable$Variance <- as.numeric(as.character(Alltreatmentstable$Variance))
+ Alltreatmentstable$Sd <- as.numeric(as.character(Alltreatmentstable$Sd))
+ Alltreatmentstable$Median <- as.numeric(as.character(Alltreatmentstable$Median))
+ Alltreatmentstable$Min <- as.numeric(as.character(Alltreatmentstable$Min))
+ Alltreatmentstable$Max <- as.numeric(as.character(Alltreatmentstable$Max))
+ Alltreatmentstable$Quartil1 <- as.numeric(as.character(Alltreatmentstable$Quartil1))
+ Alltreatmentstable$Quartil2 <- as.numeric(as.character(Alltreatmentstable$Quartil2))
+ Alltreatmentstable$CovDcDe <- as.numeric(as.character(Alltreatmentstable$CovDcDe))
+ Alltreatmentstable$Time <- as.numeric(as.character(Alltreatmentstable$Time))
+
+ if ( tipo.nodo[position] == "M") {
+ varData <- var( Data, na.rm = TRUE )
+ sdData <- sqrt(varData)
+ }
+
+ lableminsize <- tklabel(frameUpperRight,text = paste(rep("_",50),collapse="",sep=""))
+ lableminsize2 <- tklabel(frameUpperRight,text = paste(rep("_",50),collapse="",sep=""))
+# label0 <- tklabel(frameUpperRight,text= "Tempo decorrido (segundos)")
+# label1 <- tklabel(frameUpperRight,text= format(tempo, nsmall = digits) )
+ label2 <- tklabel(frameUpperRight,text= "Valor Médio")
+ label3 <- tklabel(frameUpperRight,text= format(round(meanData, digits = digits), nsmall = digits) )
+ label4 <- tklabel(frameUpperRight,text= "Variância")
+ label5 <- tklabel(frameUpperRight,text= format(round(varData, digits = digits), nsmall = digits) )
+ label6 <- tklabel(frameUpperRight,text= "Desvio Padrão")
+ label7 <- tklabel(frameUpperRight,text= format(round(sdData, digits = digits), nsmall = digits) )
+ label8 <- tklabel(frameUpperRight,text= "Mediana")
+ label9 <- tklabel(frameUpperRight,text= format(round(medianData, digits = digits), nsmall = digits) )
+ label10 <- tklabel(frameUpperRight,text= "Mínimo")
+ label11 <- tklabel(frameUpperRight,text= format(round(minData, digits = digits), nsmall = digits) )
+ label12 <- tklabel(frameUpperRight,text= "Máximo")
+ label13 <- tklabel(frameUpperRight,text= format(round(maxData, digits = digits), nsmall = digits) )
+ label14 <- tklabel(frameUpperRight,text= "1st. Quartil")
+ label15 <- tklabel(frameUpperRight,text= format(round(quartil1, digits = digits), nsmall = digits) )
+ label16 <- tklabel(frameUpperRight,text= "3rd. Quartil")
+ label17 <- tklabel(frameUpperRight,text= format(round(quartil3, digits = digits), nsmall = digits) )
+
+ tkgrid(lableminsize, row = 1, column = 0, columnspan = 2)
+# tkgrid(label0, row = 2, column = 0,sticky="w")
+# tkgrid(label1, row = 2, column = 1,sticky="e")
+ tkgrid(label2, row = 3, column = 0,sticky="w")
+ tkgrid(label3, row = 3, column = 1,sticky="e")
+ tkgrid(label4, row = 4, column = 0,sticky="w")
+ tkgrid(label5, row = 4, column = 1,sticky="e")
+ tkgrid(label6, row = 5, column = 0,sticky="w")
+ tkgrid(label7, row = 5, column = 1,sticky="e")
+ tkgrid(label8, row = 6, column = 0,sticky="w")
+ tkgrid(label9, row = 6, column = 1,sticky="e")
+ tkgrid(label10, row = 7, column = 0,sticky="w")
+ tkgrid(label11, row = 7, column = 1,sticky="e")
+ tkgrid(label12, row = 8, column = 0,sticky="w")
+ tkgrid(label13, row = 8, column = 1,sticky="e")
+ tkgrid(label14, row = 9, column = 0,sticky="w")
+ tkgrid(label15, row = 9, column = 1,sticky="e")
+ tkgrid(label16, row = 10, column = 0,sticky="w")
+ tkgrid(label17, row = 10, column = 1,sticky="e")
+ tkgrid(lableminsize2, row = 11, column = 0, columnspan = 2)
+
+ # O Custo -------------------------------------------------
+ Data <- apply( Mktable$Cost, 2, sum, na.rm = TRUE)
+ ntreat <- length(Data)
+ statisticsData <- summary(Data, na.rm = TRUE)
+
+ meanData <- mean(Data)
+ if ( tipo.nodo[position] == "M") {
+ varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2)
+ } else {
+ varData <- var( Data, na.rm = TRUE )
+ }
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ CovCE <- sum( (DataEff - mean(DataEff) * (Data - meanData)) / ( ntreat * (ntreat - 1) ) , na.rm = TRUE)
+# print(CovCE)
+ nlAllt <- dim(Alltreatmentstable)[1]
+ Alltreatmentstable$CovDcDe[ nlAllt ] <- CovCE
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "Cost", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3,
+ CovDcDe = CovCE, Time = tempo)
+
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+# print(line.data.summary)
+# print(Alltreatmentstable)
+
+ Alltreatmentstable <- as.data.frame(Alltreatmentstable)
+ Alltreatmentstable$Treatment <- as.character(Alltreatmentstable$Treatment)
+ Alltreatmentstable$Data <- as.character(Alltreatmentstable$Data)
+ Alltreatmentstable$Mean <- as.numeric(as.character(Alltreatmentstable$Mean))
+ Alltreatmentstable$Variance <- as.numeric(as.character(Alltreatmentstable$Variance))
+ Alltreatmentstable$Sd <- as.numeric(as.character(Alltreatmentstable$Sd))
+ Alltreatmentstable$Median <- as.numeric(as.character(Alltreatmentstable$Median))
+ Alltreatmentstable$Min <- as.numeric(as.character(Alltreatmentstable$Min))
+ Alltreatmentstable$Max <- as.numeric(as.character(Alltreatmentstable$Max))
+ Alltreatmentstable$Quartil1 <- as.numeric(as.character(Alltreatmentstable$Quartil1))
+ Alltreatmentstable$Quartil2 <- as.numeric(as.character(Alltreatmentstable$Quartil2))
+ Alltreatmentstable$CovDcDe <- as.numeric(as.character(Alltreatmentstable$CovDcDe))
+ Alltreatmentstable$Time <- as.numeric(as.character(Alltreatmentstable$Time))
+
+ if ( tipo.nodo[position] == "M") {
+ varData <- var( Data, na.rm = TRUE )
+ sdData <- sqrt(varData)
+ }
+
+ lableminsize <- tklabel(frameUpperLeft,text = paste(rep("_",50),collapse="",sep=""))
+ lableminsize2 <- tklabel(frameUpperLeft,text = paste(rep("_",50),collapse="",sep=""))
+# label0 <- tklabel(frameUpperLeft,text= "Tempo decorrido (segundos)")
+# label1 <- tklabel(frameUpperLeft,text= format(tempo, nsmall = digits) )
+ label2 <- tklabel(frameUpperLeft,text= "Valor Médio")
+ label3 <- tklabel(frameUpperLeft,text= format(round(meanData, digits = digits), nsmall = digits) )
+ label4 <- tklabel(frameUpperLeft,text= "Variância")
+ label5 <- tklabel(frameUpperLeft,text= format(round(varData, digits = digits), nsmall = digits) )
+ label6 <- tklabel(frameUpperLeft,text= "Desvio Padrão")
+ label7 <- tklabel(frameUpperLeft,text= format(round(sdData, digits = digits), nsmall = digits) )
+ label8 <- tklabel(frameUpperLeft,text= "Mediana")
+ label9 <- tklabel(frameUpperLeft,text= format(round(medianData, digits = digits), nsmall = digits) )
+ label10 <- tklabel(frameUpperLeft,text= "Mínimo")
+ label11 <- tklabel(frameUpperLeft,text= format(round(minData, digits = digits), nsmall = digits) )
+ label12 <- tklabel(frameUpperLeft,text= "Máximo")
+ label13 <- tklabel(frameUpperLeft,text= format(round(maxData, digits = digits), nsmall = digits) )
+ label14 <- tklabel(frameUpperLeft,text= "1st. Quartil")
+ label15 <- tklabel(frameUpperLeft,text= format(round(quartil1, digits = digits), nsmall = digits) )
+ label16 <- tklabel(frameUpperLeft,text= "3rd. Quartil")
+ label17 <- tklabel(frameUpperLeft,text= format(round(quartil3, digits = digits), nsmall = digits) )
+
+ tkgrid(lableminsize, row = 1, column = 0, columnspan = 2)
+# tkgrid(label0, row = 2, column = 0,sticky="w")
+# tkgrid(label1, row = 2, column = 1,sticky="e")
+ tkgrid(label2, row = 3, column = 0,sticky="w")
+ tkgrid(label3, row = 3, column = 1,sticky="e")
+ tkgrid(label4, row = 4, column = 0,sticky="w")
+ tkgrid(label5, row = 4, column = 1,sticky="e")
+ tkgrid(label6, row = 5, column = 0,sticky="w")
+ tkgrid(label7, row = 5, column = 1,sticky="e")
+ tkgrid(label8, row = 6, column = 0,sticky="w")
+ tkgrid(label9, row = 6, column = 1,sticky="e")
+ tkgrid(label10, row = 7, column = 0,sticky="w")
+ tkgrid(label11, row = 7, column = 1,sticky="e")
+ tkgrid(label12, row = 8, column = 0,sticky="w")
+ tkgrid(label13, row = 8, column = 1,sticky="e")
+ tkgrid(label14, row = 9, column = 0,sticky="w")
+ tkgrid(label15, row = 9, column = 1,sticky="e")
+ tkgrid(label16, row = 10, column = 0,sticky="w")
+ tkgrid(label17, row = 10, column = 1,sticky="e")
+ tkgrid(lableminsize2, row = 11, column = 0, columnspan = 2)
+
+ tkgrid(frameUpperLeft, frameUpperRight, sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ tkpack(frameWindow, expand = 1, fill = "both")
+ tkgrid(PageNoteBook.Window)
+
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Cost,2,sum, na.rm = TRUE) / apply(Mktable$Effectiveness, 2, sum, na.rm = TRUE)
+ Data <- replace( Data, Data == Inf, NA)
+
+ statisticsData <- summary(Data, na.rm = TRUE)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE)
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "C/E", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3,
+ CovDcDe = NA, Time = tempo)
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+ }
+
+ # Uma limpeza na memória...
+ rm(Data, statisticsData, Mktable, CovCE, nlAllt, meanData, varData, sdData, medianData, minData, maxData,
+ quartil1, quartil3)
+
+ # Ajusta o Alltreatmentstable
+ rownames(Alltreatmentstable) <- NULL
+ Alltreatmentstable <- as.data.frame(Alltreatmentstable)
+ Alltreatmentstable$Treatment <- as.character(Alltreatmentstable$Treatment)
+ Alltreatmentstable$Data <- as.character(Alltreatmentstable$Data)
+ Alltreatmentstable$Mean <- as.numeric(as.character(Alltreatmentstable$Mean))
+ Alltreatmentstable$Variance <- as.numeric(as.character(Alltreatmentstable$Variance))
+ Alltreatmentstable$Sd <- as.numeric(as.character(Alltreatmentstable$Sd))
+ Alltreatmentstable$Median <- as.numeric(as.character(Alltreatmentstable$Median))
+ Alltreatmentstable$Min <- as.numeric(as.character(Alltreatmentstable$Min))
+ Alltreatmentstable$Max <- as.numeric(as.character(Alltreatmentstable$Max))
+ Alltreatmentstable$Quartil1 <- as.numeric(as.character(Alltreatmentstable$Quartil1))
+ Alltreatmentstable$Quartil2 <- as.numeric(as.character(Alltreatmentstable$Quartil2))
+ Alltreatmentstable$CovDcDe <- as.numeric(as.character(Alltreatmentstable$CovDcDe))
+ Alltreatmentstable$Time <- as.numeric(as.character(Alltreatmentstable$Time))
+ Alltreatmentstable <- Alltreatmentstable[ order(Alltreatmentstable$Data),]
+# print(Alltreatmentstable)
+ assign("Alltreatmentstable", Alltreatmentstable, env = .GlobalEnv)
+
+ # The data to plot
+ AllTreatCost <- Alltreatmentstable[Alltreatmentstable$Data == "Cost",]
+ AllTreatEffectiveness <- Alltreatmentstable[Alltreatmentstable$Data == "Effectiveness",]
+ AllTreatCE <- Alltreatmentstable[Alltreatmentstable$Data == "C/E",]
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(AllTreatCost$Treatment)
+ # The treatments names
+ treatments.label.plot <- AllTreatCost$Treatment
+
+ n.treat <- c(0,length(treatments.sim):1,0,length(treatments.sim))
+ for (i in n.treat) {
+ pagetclname <- paste("Page",i, sep="")
+ tcl(pBar,"raise",pagetclname)
+ }
+
+ tcl(pBar,"itemconfigure", "Page0", "-state", "disabled") # Set Page0 page to disabled.
+
+ OnOK <- function()
+ {
+ tkdestroy(summarysimulationWindow)
+ tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ OnGraph <- function(Mktable, Alltreatmentstable) {
+
+ selectedpage.number <- tclvalue(tcl(pBar,"raise")) # Retorna a página selecionada
+ selectedpage.number <- as.numeric(substr(selectedpage.number,5,nchar(selectedpage.number)))
+ selected.treatment <- treatments.sim[selectedpage.number]
+ Mktable <- Simlist[[selected.treatment]]
+
+ onGraph.summary.simwindow(Mktable, Alltreatmentstable, selected.treatment)
+ }
+
+ OnText <- function() {
+ StatsData <- Alltreatmentstable[ order(Alltreatmentstable$Treatment, Alltreatmentstable$Data),]
+ assign("StatsData", StatsData, .EnvironmentArvoRe)
+
+ Costdata <- subset(StatsData, Data == "Cost")
+ Effectivenessdata <- subset(StatsData, Data == "Effectiveness")
+ CEdata <- subset(StatsData, Data == "C/E")
+
+ statsSWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Estatísticas"
+ tkwm.title(statsSWindow, title.window)
+
+ frameOverall <- tkwidget(statsSWindow, "labelframe", borderwidth = 2, relief = "groove")
+ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0)
+
+ OnNM <- function() {
+ WTPVal <- as.numeric(tclvalue(WTPvar))
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+ Data <- DataEffectiveness * WTPVal - DataCost
+ NMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ namesvariables <- c(".Cost", ".Effectiveness", ".NMB")
+ names(NMBtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+ Data <- DataEffectiveness * WTPVal - DataCost
+
+ newNMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ names(newNMBtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ NMBtable <- abind(NMBtable, newNMBtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ NMBtable <- abind(Trial, NMBtable, along=2)
+ names(NMBtable) <- c("Trial", names(NMBtable))
+
+ tituloNMB <- "Estatísticas - Net Monetary Benefits"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnNH <- function() {
+ WTPVal <- as.numeric(tclvalue(WTPvar))
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The NHB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+ Data <- DataEffectiveness - DataCost / WTPVal
+
+ NHBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NHB = Data)
+ namesvariables <- c(".Cost", ".Effectiveness", ".NHB")
+ names(NHBtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+ Data <- DataEffectiveness - DataCost / WTPVal
+
+ newNHBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NHB = Data)
+ names(newNHBtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ NHBtable <- abind(NHBtable, newNHBtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ NHBtable <- abind(Trial, NHBtable, along=2)
+ names(NHBtable) <- c("Trial", names(NHBtable))
+
+ tituloNHB <- "Estatísticas - Rede de Benefício Saúde (NHB)"
+ NHBtable <- as.matrix(NHBtable)
+
+ displayInTable(NHBtable, title = tituloNHB, height=min(10,dim(NHBtable)[1]), width= min(10,dim(NHBtable)[2]),
+ nrow=dim(NHBtable)[1],ncol=dim(NHBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnCE <- function() {
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+
+ CEtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ CE = DataCost / DataEffectiveness)
+ namesvariables <- c(".Cost", ".Effectiveness", ".CE")
+ names(CEtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+
+ newCEtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ CE = DataCost / DataEffectiveness)
+ names(newCEtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ CEtable <- abind(CEtable, newCEtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ CEtable <- abind(Trial, CEtable, along=2)
+ names(CEtable) <- c("Trial", names(CEtable))
+
+ tituloCE <- "Estatísticas - Análise de Custo-Efetividade"
+ CEtable <- as.matrix(CEtable)
+
+ displayInTable(CEtable, title = tituloCE, height=min(10,dim(CEtable)[1]), width= min(10,dim(CEtable)[2]),
+ nrow=dim(CEtable)[1],ncol=dim(CEtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+
+ label1 <- "Rede de Benefício Monetário (NMB)"
+ label2 <- "Rede de Benefício Saúde (NHB)"
+ label3 <- "Custo-Efetividade (CE)"
+
+ .Width.but <- max(nchar(c(label1, label2, label3))) + 2
+ .Height.but <- 1
+
+ NM.but <-tkbutton(frameOverall,text=label1, width=.Width.but, height=.Height.but, command=OnNM)
+ NH.but <-tkbutton(frameOverall,text=label2, width=.Width.but, height=.Height.but, command=OnNH)
+ CE.but <-tkbutton(frameOverall,text=label3, width=.Width.but, height=.Height.but, command=OnCE)
+
+ tkgrid(NM.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(NH.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(frameOverall,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(frameOverall,text="Valor do willingness-to-pay (WTP)"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, row = 5, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(frameOverall,text=" "),
+ row = 6, column = 0, columnspan = 2, sticky = "n")
+
+
+ tkgrid( frameOverall, sticky = "n", columnspan = 2, padx = 5, pady = 5)
+ tkgrid( frameButtons, sticky = "s")
+
+ OnOK <- function() {
+ tkdestroy(statsSWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ tkbind(statsSWindow, "<Return>",OnOK)
+ tkbind(statsSWindow, "<Escape>",OnOK)
+
+ OK.but <-tkbutton(frameButtons,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+# Cancel.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+
+ tkgrid(OK.but, sticky = "s", columnspan = 2, padx = 5, pady = 5)
+
+ }
+
+ OnExport <- function() {
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(summarysimulationWindow)
+ else {
+ selectedpage.number <- tclvalue(tcl(pBar,"raise")) # Retorna a página selecionada
+ selectedpage.number <- as.numeric(substr(selectedpage.number,5,nchar(selectedpage.number)))
+ selected.treatment <- treatments.sim[selectedpage.number]
+ Mktable <- Simlist[[selected.treatment]]
+
+ if (tipo.nodo[selectedpage.number] == "C") {
+ ResumeSim <- data.frame(Cost = apply(Mktable$Cost,2,sum, na.rm = TRUE),
+ Effectiveness = apply(Mktable$Effectiveness,2,sum, na.rm = TRUE))
+ ResumeSim <- data.frame(Trial = 0:(dim(ResumeSim)[1] - 1), ResumeSim)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ } else {
+ if (tipo.nodo[selectedpage.number] == "M") {
+
+ # Summary Coort
+ ResumeSim <- data.frame(Cost = apply(Mktable$Cost,2,sum, na.rm = TRUE),
+ Effectiveness = apply(Mktable$Effectiveness,2,sum, na.rm = TRUE))
+ ResumeSim <- data.frame(Individual = 1:(dim(ResumeSim)[1]), ResumeSim)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+
+ # Full detail
+ Cycle <- 0:(dim(Mktable$Path)[1] - 1)
+ ResumeSim.Cost <- data.frame( Cycle, Mktable$Cost )
+ ResumeSim.Effectiveness <- data.frame( Cycle, Mktable$Effectiveness )
+ ResumeSim.Path <- data.frame( Cycle, Mktable$Path )
+
+# print(fileName)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( substr(fileName,nchar(fileName)-3,nchar(fileName)-3) == "." ) {
+ ans.root.file.name <- substr(fileName,1,nchar(fileName)-4)
+ } else {
+ ans.root.file.name <- fileName
+ }
+
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+# print("Estou salvando")
+ fileName <- paste(ans.root.file.name," Cost", ans, sep = "")
+ write.csv2(ResumeSim.Cost, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name," Effectiveness", ans, sep = "")
+ write.csv2(ResumeSim.Effectiveness, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name," Path", ans, sep = "")
+ write.csv2(ResumeSim.Path, file = fileName, row.names = FALSE)
+ } else {
+# print("Estou salvando")
+ fileName <- paste(ans.root.file.name, " Cost", ".csv", sep = "")
+ write.csv2(ResumeSim.Cost, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name, " Effectiveness", ".csv", sep = "")
+ write.csv2(ResumeSim.Effectiveness, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name, " Path", ".csv", sep = "")
+ write.csv2(ResumeSim.Path, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+
+ } else {
+ cat("Aviso: não é possível exportar resultados para nodo Terminal")
+ }
+ }
+
+ tkfocus(summarysimulationWindow)
+ }
+
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+
+ OnStatsRep <- function() {
+ StatsData <- Alltreatmentstable[ order(Alltreatmentstable$Treatment, Alltreatmentstable$Data),]
+ assign("StatsData", StatsData, .EnvironmentArvoRe)
+
+ Costdata <- subset(StatsData, Data == "Cost")
+ Effectivenessdata <- subset(StatsData, Data == "Effectiveness")
+ CEdata <- subset(StatsData, Data == "C/E")
+
+
+# print(StatsData)
+
+ statsSWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Estatísticas"
+ tkwm.title(statsSWindow, title.window)
+
+ frameOverall <- tkwidget(statsSWindow, "labelframe", borderwidth = 2, relief = "groove")
+ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0)
+
+ OnNM <- function() {
+ WTPVal <- as.numeric(tclvalue(WTPvar))
+
+ NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0), Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0))
+
+ for (i in 1:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) *
+ WTPVal - apply(Mktable$Cost,2,sum, na.rm = TRUE)
+
+ statisticsData <- summary(Data, na.rm = TRUE)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE, use = "complete.obs")
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = selected.treatment, Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3)
+ NMBtable <- abind(NMBtable, line.data.summary, along=1)
+ }
+
+ tituloNMB <- "Estatísticas - Rede de Benefício Monetário (NMB)"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnNH <- function() {
+ WTPVal <- as.numeric(tclvalue(WTPvar))
+
+ NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0), Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0))
+
+ for (i in 1:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NHB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) *
+ apply(Mktable$Cost,2,sum, na.rm = TRUE) / WTPVal
+
+ statisticsData <- summary(Data, na.rm = TRUE)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE, use = "complete.obs")
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = selected.treatment, Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3)
+ NMBtable <- abind(NMBtable, line.data.summary, along=1)
+ }
+
+ tituloNMB <- "Estatísticas - Rede de Benefício Monetário (NMB)"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+
+ }
+
+ OnCE <- function() {
+ tituloCE <- "Estatísticas - Análise de Custo-Efetividade"
+ StatsData <- as.matrix(StatsData)
+
+ displayInTable(StatsData, title = tituloCE, height=min(10,dim(StatsData)[1]), width= min(10,dim(StatsData)[2]),
+ nrow=dim(StatsData)[1],ncol=dim(StatsData)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnICER <- function(Alltreatmentstable) {
+ icer.sim.window(Alltreatmentstable)
+ }
+
+ OnINB <- function(Alltreatmentstable) {
+ inb.sim.window(Alltreatmentstable)
+ }
+
+ .Width.but <- 40
+ .Height.but <- 1
+
+ NM.but <-tkbutton(frameOverall,text="Rede de Benefício Monetário (NMB)", width=.Width.but, height=.Height.but, command=OnNM)
+ NH.but <-tkbutton(frameOverall,text="Rede de Benefício Saúde (NHB)", width=.Width.but, height=.Height.but, command=OnNH)
+ CE.but <-tkbutton(frameOverall,text="Custo-Efetividade (CE)", width=.Width.but, height=.Height.but, command=OnCE)
+ ICER.but <-tkbutton(frameOverall,text="Razão adicional de C-E (ICER)", width=.Width.but, height=.Height.but,
+ command= function() OnICER(StatsData))
+ INB.but <-tkbutton(frameOverall,text="Incremento da rede de benefícios (INB)", width=.Width.but,
+ height=.Height.but, command= function() OnINB(StatsData))
+
+
+ tkgrid(NM.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(NH.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(ICER.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(INB.but, sticky = "s", padx = 5, pady = 5)
+
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(frameOverall,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(frameOverall,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(frameOverall,text=" "),
+ columnspan = 2, sticky = "n")
+
+
+ tkgrid( frameOverall, sticky = "n", columnspan = 2, padx = 5, pady = 5)
+ tkgrid( frameButtons, sticky = "s")
+
+ OnOK <- function() {
+ tkdestroy(statsSWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ tkbind(statsSWindow, "<Return>",OnOK)
+ tkbind(statsSWindow, "<Escape>",OnOK)
+
+ OK.but <-tkbutton(frameButtons,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+# Cancel.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+
+ tkgrid(OK.but, sticky = "s", columnspan = 2, padx = 5, pady = 5)
+ tkfocus(statsSWindow)
+ }
+
+ .Width.but <- 18
+ .Height.but <- 1
+
+ OK.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but,
+ command=OnOK)
+ StatsRep.but <-tkbutton(framePanelButton,text="Estatísticas", width=.Width.but, height=.Height.but,
+ command=OnStatsRep)
+ Graph.but <-tkbutton(framePanelButton,text="Gráficos", width=.Width.but, height=.Height.but,
+ command = function() OnGraph(Mktable, Alltreatmentstable) )
+ TextRep.but <-tkbutton(framePanelButton,text="Relatório Texto", width=.Width.but, height=.Height.but,
+ command=OnText)
+ Export.but <-tkbutton(framePanelButton,text="Exportar Relatório", width=.Width.but, height=.Height.but,
+ command=OnExport)
+
+ tkbind(summarysimulationWindow, "<Return>",OnOK)
+ tkbind(summarysimulationWindow, "<Escape>",OnOK)
+
+
+ tkgrid(StatsRep.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Graph.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(TextRep.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Export.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(OK.but, sticky = "s", padx = 5, pady = 5)
+
+# posiciona.janela.centro(tt, summarysimulationWindow)
+
+ tkfocus(summarysimulationWindow)
+
+}
+
Property changes on: pkg/R/summary.simulation.window.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/terminal.markov.coort.table.R
===================================================================
--- pkg/R/terminal.markov.coort.table.R (rev 0)
+++ pkg/R/terminal.markov.coort.table.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,10 @@
+`terminal.markov.coort.table` <-
+function(TheTree, trials = 2) {
+ # cria a tabela de resposta
+ Coorte.Ind <- matrix("1",1,trials) # Matriz com cada individuo
+ Coorte.Cost <- matrix(TheTree$Payoff1,1,trials) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(TheTree$Payoff2,1,trials) # Matriz com a efetividade de cada individuo
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec)
+ return(ans) # And return the result
+}
+
Property changes on: pkg/R/terminal.markov.coort.table.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/theTreeTkArvore.R
===================================================================
--- pkg/R/theTreeTkArvore.R (rev 0)
+++ pkg/R/theTreeTkArvore.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,50 @@
+`theTreeTkArvore` <-
+function(TheTree) {
+
+ num.lin <- dim(TheTree)[1]
+ num.levels <- max(TheTree$Level)
+
+ for (i in 1:length(.libPaths())) {
+ SubDataSet <- subset(TheTree, Level == 1)
+ osnodos <- SubDataSet$Node.N
+ osnodosnomes <- SubDataSet$Node.name
+ osnodostipos <- SubDataSet$Type
+ osnodos <- paste(i,".",osnodos,sep="")
+
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/", osnodostipos,".png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ tkinsert(treeWidget,"end","root","1.1",text=osnodosnomes, image = icn)
+ } else {
+ tkinsert(treeWidget,"end","root","1.1",text=osnodosnomes)
+ }
+ }
+
+ if (num.lin > 1) {
+ for (i in 2:num.levels) {
+ SubDataSet <- subset(TheTree, Level == i)
+ osnodos <- SubDataSet$Node.N
+ paisnodos <- SubDataSet$Father
+ osnodosnomes <- SubDataSet$Node.name
+ osnodostipos <- SubDataSet$Type
+# cat("DEBUG : Criei os nodos \n ", osnodos, " cujos pais são ", paisnodos, "\n")
+
+ osnodos <- paste(i,".",osnodos,sep="")
+ paisnodos <- paste((i-1),".",paisnodos,sep="")
+
+ for (j in 1:length(osnodos)) {
+ tipofilename <- osnodostipos[j]
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/", tipofilename,".png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ tkinsert(treeWidget,"end",paisnodos[j],osnodos[j],text=osnodosnomes[j], image = icn)
+ } else {
+ tkinsert(treeWidget,"end",paisnodos[j],osnodos[j],text=osnodosnomes[j])
+ }
+ }
+ }
+ }
+ }
+}
+
Property changes on: pkg/R/theTreeTkArvore.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/typenodewindows.R
===================================================================
--- pkg/R/typenodewindows.R (rev 0)
+++ pkg/R/typenodewindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,164 @@
+`typenodewindows` <-
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ # A janela Tk
+ typenodeWindow <- tktoplevel(height = 200, width = 150)
+ title <- "ÁrvoRe - Tipo Nodo"
+ tkwm.title(typenodeWindow,title)
+ tkgrid(tklabel(typenodeWindow,text="Selecione o tipo do nodo"), column = 0, row = 0, sticky = "n")
+
+ Frame1 <- tkframe(typenodeWindow, height = 200, width = 150,
+ borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(typenodeWindow, height = 200, width = 150,
+ borderwidth = 0, relief = "groove")
+
+ tkgrid(Frame1, sticky = "n")
+ tkgrid(Frame2, sticky = "s")
+
+ # Type Chance
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/C.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb1 <- tkradiobutton(Frame1)
+ rbValue <- tclVar("C")
+ tkconfigure(rb1,variable=rbValue,value="C")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Chance "),rb1, sticky = "ne")
+
+ } else {
+ rb1 <- tkradiobutton(Frame1)
+ rbValue <- tclVar("C")
+ tkconfigure(rb1,variable=rbValue,value="C")
+ tkgrid( tklabel(Frame1,text="Chance "),rb1, sticky = "ne")
+ }
+ }
+
+ # Type Decision
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/D.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb2 <- tkradiobutton(Frame1)
+ tkconfigure(rb2, variable=rbValue, value="D")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Decision "),rb2, sticky = "ne")
+
+ } else {
+ rb2 <- tkradiobutton(Frame1)
+ tkconfigure(rb2,variable=rbValue,value="D")
+ tkgrid( rb2, column = 0, row = 2, sticky = "nw")
+ tkgrid( tklabel(Frame1,text="Decision "),rb2, sticky = "ne")
+ }
+ }
+
+ # Type Logic
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/L.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb3 <- tkradiobutton(Frame1)
+ tkconfigure(rb3,variable=rbValue,value="L")
+ rb3text <- tklabel(Frame1,text="Logic ")
+ tkgrid( tklabel(Frame1,image=icn), rb3text,
+ rb3, sticky = "ne")
+ } else {
+ rb3 <- tkradiobutton(Frame1)
+ tkconfigure(rb3,variable=rbValue,value="L")
+ rb3text <- tklabel(Frame1,text="Logic ")
+ tkgrid( rb3text ,rb3, sticky = "ne")
+ }
+ }
+
+ tkconfigure(rb3, state = "disabled")
+ tkconfigure(rb3text, state = "disabled")
+
+ # Type Markov
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/M.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb4 <- tkradiobutton(Frame1)
+ tkconfigure(rb4,variable=rbValue,value="M")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Markov "),rb4, sticky = "ne")
+ } else {
+ rb4 <- tkradiobutton(Frame1)
+ tkconfigure(rb4,variable=rbValue,value="M")
+ tkgrid( tklabel(Frame1,text="Markov ") ,rb4, sticky = "ne")
+ }
+ }
+
+ # Type Terminal
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/T.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb5 <- tkradiobutton(Frame1)
+ tkconfigure(rb5,variable=rbValue,value="T")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Terminal "),rb5, sticky = "ne")
+ } else {
+ rb5 <- tkradiobutton(Frame1)
+ tkconfigure(rb5,variable=rbValue,value="T")
+ tkgrid( tklabel(Frame1,text="Terminal ") ,rb5, sticky = "ne")
+ }
+ }
+
+ # Type Label
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/X.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb6 <- tkradiobutton(Frame1)
+ tkconfigure(rb6,variable=rbValue,value="X")
+ rb6text <- tklabel(Frame1,text="Label ")
+ tkgrid( tklabel(Frame1,image=icn), rb6text, rb6, sticky = "ne")
+ } else {
+ rb6 <- tkradiobutton(Frame1)
+ tkconfigure(rb6,variable=rbValue,value="X")
+ rb6text <- tklabel(Frame1,text="Label ")
+ tkgrid( rb6text ,rb6, sticky = "ne")
+ }
+ }
+
+ tkconfigure(rb6, state = "disabled")
+ tkconfigure(rb6text, state = "disabled")
+
+ tkfocus(typenodeWindow)
+
+ OnOK <- function()
+ {
+ nodo.type <- as.character(tclvalue(rbValue))
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ settypenode(TheTree, column = column, node.number = node.number, nodo.type = nodo.type, .EnvironmentArvoRe)
+ refreshF5()
+ tkdestroy(typenodeWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(typenodeWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(Frame2,text=" OK ",command=OnOK)
+ tkbind(typenodeWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(Frame2,text=" Cancelar ",command=OnCancel)
+ tkbind(typenodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(typenodeWindow, 150, 200)
+ }
+}
+
Property changes on: pkg/R/typenodewindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/utilitywindows.R
===================================================================
--- pkg/R/utilitywindows.R (rev 0)
+++ pkg/R/utilitywindows.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,73 @@
+`utilitywindows` <-
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ utilityWindow <- tktoplevel()
+ title <- "ÁrvoRe - Payoffs Nodo"
+ tkwm.title(utilityWindow,title)
+
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ utilityvar <- tclVar(TheTree$Payoff1[position])
+ effectivenessvar <- tclVar(TheTree$Payoff2[position])
+
+ entry.Value <- tkentry(utilityWindow,width="20",textvariable=utilityvar)
+ tkgrid(tklabel(utilityWindow,text="Valor do custo"))
+ tkgrid(entry.Value)
+
+ entry.Value.effectiveness <- tkentry(utilityWindow,width="20",textvariable=effectivenessvar)
+ label.entry.Value.effect <- tklabel(utilityWindow,text="Valor da efetividade")
+ tkgrid(label.entry.Value.effect)
+ tkgrid(entry.Value.effectiveness)
+
+ if (.modeltypeArvore == "SD") {
+ tkconfigure(entry.Value.effectiveness, state = "disabled")
+ tkconfigure(label.entry.Value.effect, state = "disabled")
+ }
+
+ OnOK <- function()
+ {
+ utilityVal <- as.numeric(tclvalue(utilityvar))
+ effectivenessVal <- as.numeric(tclvalue(effectivenessvar))
+
+ if ( (is.numeric(utilityVal)) && (!is.na(utilityVal)) &&
+ (is.numeric(effectivenessVal)) && (!is.na(effectivenessVal)) ) {
+ tkdestroy(utilityWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setutility(TheTree, nodeSec[2], nodeSec[3], utilityVal, .EnvironmentArvoRe)
+ seteffectiveness(TheTree, nodeSec[2], nodeSec[3], effectivenessVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor de utilidade válido '",utilityVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(utilityWindow)
+ }
+ }
+ OK.but <-tkbutton(utilityWindow,text=" OK ",command=OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(utilityWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(utilityWindow,text=" Cancelar ",command=OnCancel)
+
+ tkbind(entry.Value, "<Return>",OnOK)
+ tkbind(entry.Value.effectiveness, "<Return>",OnOK)
+ tkbind(utilityWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(utilityWindow, 200, 130)
+ tkfocus(utilityWindow)
+ }
+}
+
Property changes on: pkg/R/utilitywindows.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/windowresolution.R
===================================================================
--- pkg/R/windowresolution.R (rev 0)
+++ pkg/R/windowresolution.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,65 @@
+# FUNCTION :: windowresolution # Criada em July 02, 2008 02:33:36 PM
+# This function is the GUI to do something.
+#
+#
+# Revision : xxxx - xxx
+#
+#
+# Parameters
+
+# Esta função faz alguma coisa
+
+windowresolution <- function() {
+ # Criação da janela
+ win.main.resWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - Tamanho da Janela" # Título da janela
+ tkwm.title(win.main.resWindow, title.window)
+
+ # Variáveis TclTk
+ qualquercoisa.tclvar <- tclVar( 0000 )
+
+ # Frames da janela
+ FrameOverAll <- tkframe(win.main.resWindow, height = 200, width = 150, borderwidth = 0, relief = "groove")
+ FrameButtons <- tkframe(win.main.resWindow, height = 200, width = 150, borderwidth = 0, relief = "groove")
+
+ tkpack(FrameOverAll)
+ tkpack(FrameButtons)
+
+ # Check bottons
+
+ # List box
+
+
+ tkgrid(FrameButtons, columnspan = 2, sticky = "s")
+
+#------- BOTOES ---------------------------------------------------------------------------------------------
+ OnOK <- function() {
+
+ }
+
+ OnCancel <- function() {
+ tkdestroy(win.main.resWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ rotulo <- "OK"
+ OK.but <- tkbutton(FrameButtons, text = rotulo, width = .Width.but, height = .Height.but,
+ command = OnOK)
+ rotulo <- "Cancelar"
+ Cancel.but <- tkbutton(FrameButtons, text = rotulo, width = .Width.but, height = .Height.but,
+ command = OnCancel)
+
+ tkgrid(OK.but, Cancel.but, columnspan = 2, sticky = "s", padx = 5, pady = 5)
+#------- TECLAS ATALHO --------------------------------------------------------------------------------------
+ tkbind(win.main.resWindow, "<Return>", OnOK)
+ tkbind(win.main.resWindow, "<Escape>", OnCancel)
+#------- MONTAGEM FINAL -------------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------------------------------------
+ tkfocus(win.main.resWindow)
+
+
+}
Property changes on: pkg/R/windowresolution.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/zoom.in.but.R
===================================================================
--- pkg/R/zoom.in.but.R (rev 0)
+++ pkg/R/zoom.in.but.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,19 @@
+`zoom.in.but` <-
+function(imgHeight) {
+ if (imgHeight < 8000) {
+ imgHeight <- round(imgHeight * 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ } else {
+ msg <- paste("Este é um tamanho de imagem consideravelmente grande. Deseja realmente ampliar?")
+ ans <- tkmessageBox(message = msg, icon = "question", type = "yesnocancel", default = "no")
+ ans <- as.character(tclvalue(ans))
+ if ( ans == "yes" ) {
+ imgHeight <- round(imgHeight * 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ }
+ tkfocus(tt)
+ }
+ set.zoom.image.tree(imgHeight, imgWidth)
+ refreshF5()
+}
+
Property changes on: pkg/R/zoom.in.but.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/R/zoom.out.but.R
===================================================================
--- pkg/R/zoom.out.but.R (rev 0)
+++ pkg/R/zoom.out.but.R 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,10 @@
+`zoom.out.but` <-
+function(imgHeight) {
+ if (imgHeight >= 320) {
+ imgHeight <- round(imgHeight / 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ set.zoom.image.tree(imgHeight, imgWidth)
+ }
+ refreshF5()
+}
+
Property changes on: pkg/R/zoom.out.but.R
___________________________________________________________________
Name: svn:eol-style
+ native
Added: pkg/icons/Arvore.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Arvore.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/ArvoreIco.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/ArvoreIco.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Ball.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Ball.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/C.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/C.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Conf.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Conf.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Copy.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Copy.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Cut.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Cut.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/D.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/D.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Display.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Display.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Display_add.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Display_add.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Display_delete.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Display_delete.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Exit.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Exit.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Export.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Export.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Graph.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Graph.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Graph2.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Graph2.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/GraphBar.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/GraphBar.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/GraphLine.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/GraphLine.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Icon.bmp
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Icon.bmp
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: pkg/icons/L.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/L.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/M.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/M.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Markov.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Markov.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/New.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/New.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Node.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Node.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Open.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Open.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Paste.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Paste.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Printer.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Printer.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Redo.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Redo.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Redraw.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Redraw.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Run.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Run.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Save.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Save.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/SaveAs.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/SaveAs.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Settings.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Settings.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Simulation.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Simulation.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/T.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/T.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Undo.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Undo.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/Variable.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/Variable.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/World.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/World.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/X.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/X.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/ZoomMinus.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/ZoomMinus.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/icons/ZoomPlus.png
===================================================================
(Binary files differ)
Property changes on: pkg/icons/ZoomPlus.png
___________________________________________________________________
Name: svn:mime-type
+ image/png
Added: pkg/man/ArvoRe-package.Rd
===================================================================
--- pkg/man/ArvoRe-package.Rd (rev 0)
+++ pkg/man/ArvoRe-package.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,42 @@
+\name{ArvoRe-package}
+\alias{ArvoRe-package}
+\alias{ArvoRe}
+\docType{package}
+\title{
+What the package does (short line)
+~~ package title ~~
+}
+\description{
+More about what it does (maybe more than one line)
+~~ A concise (1-5 lines) description of the package ~~
+}
+\details{
+\tabular{ll}{
+Package: \tab ArvoRe\cr
+Type: \tab Package\cr
+Version: \tab 1.0\cr
+Date: \tab 2008-06-25\cr
+License: \tab What license is it under?\cr
+}
+~~ An overview of how to use the package, including the most important ~~
+~~ functions ~~
+}
+\author{
+Who wrote it
+
+Maintainer: Who to complain to <yourfault at somewhere.net>
+~~ The author and/or maintainer of the package ~~
+}
+\references{
+~~ Literature or other references for background information ~~
+}
+~~ Optionally other standard keywords, one per line, from file KEYWORDS in ~~
+~~ the R documentation directory ~~
+\keyword{ package }
+\seealso{
+~~ Optional links to other man pages, e.g. ~~
+~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
+}
+\examples{
+~~ simple examples of the most important functions ~~
+}
Added: pkg/man/String2Numeric.Rd
===================================================================
--- pkg/man/String2Numeric.Rd (rev 0)
+++ pkg/man/String2Numeric.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,46 @@
+\name{String2Numeric}
+\alias{String2Numeric}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+String2Numeric(s)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{s}{ ~~Describe \code{s} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(s) {
+ ans <- exec.text(s)
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/aceptability.sim.window.Rd
===================================================================
--- pkg/man/aceptability.sim.window.Rd (rev 0)
+++ pkg/man/aceptability.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,512 @@
+\name{aceptability.sim.window}
+\alias{aceptability.sim.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+aceptability.sim.window(Alltreatmentstable)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Alltreatmentstable}{ ~~Describe \code{Alltreatmentstable} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(Alltreatmentstable) {
+ require(abind)
+
+ ACsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Curva de Aceitabilidade (INB)"
+ tkwm.title(ACsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(ACsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # The WTP ---------------------------------------------------------------------
+ WTPL1var <- tclVar(0.1)
+ WTPL2var <- tclVar(10000)
+ WTPpointsvar <- tclVar(10)
+ PoinsOriginal <- 10
+
+ WTPL1Value <- tkentry(Frame1,width="20",textvariable=WTPL1var)
+ tkgrid(tklabel(Frame1,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPL1Value, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ WTPL2Value <- tkentry(Frame1,width="20",textvariable=WTPL2var)
+ tkgrid(tklabel(Frame1,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPL2Value, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ ### Numeric format settings ###
+ numericSpinBox <- tkwidget(Frame1, "SpinBox", editable=FALSE, range = c(0,100,1), width = 3)
+ labeldigits <- tklabel(Frame1,text="Número de intervalor:")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", PoinsOriginal,sep = ""))
+
+
+ # Monta os frames
+ tkgrid(Frame1, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(Frame2, sticky = "s", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+ WTPL1Val <- as.numeric(tclvalue(WTPL1var))
+ WTPL2Val <- as.numeric(tclvalue(WTPL2var))
+ WTPPoints <- as.integer(tclvalue(tcl(numericSpinBox,"getvalue")))
+
+ WTP <- seq(WTPL1Val, WTPL2Val, (WTPL2Val-WTPL1Val)/WTPPoints )
+
+ WTPVal <- 0.1
+
+ if ( WTPL1Val < WTPL2Val ) {
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+ ans <- data.frame( Standart = rep(0,length(WTP)))
+ names.ans <- c("Standart")
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ inb <- (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1]) *
+ WTP - (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1])
+ var.inb <- ( WTP^2
+ ) * Data.alternative.Effectiveness$Variance[i] +
+ Data.alternative.Cost$Variance[i] -
+ 2 * WTP * ( 00000 )
+ inb.stat.test <- inb/var.inb^0.5
+ Strategy <- Data.alternative.Cost$Treatment[i]
+ p.val.inb <- pnorm(inb.stat.test)
+
+ ans.line <- data.frame( p.val.inb )
+ names.ans <- c(names.ans, Strategy)
+ ans <- abind(ans, ans.line, along = 2)
+
+ }
+ ans <- as.data.frame(ans)
+ names(ans) <- names.ans
+# print(ans)
+
+ OnAC <- function(WTP, ACProbabilities) {
+ ACGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Graphics"
+ tkwm.title(ACGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(ACGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(ACGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(names(ACProbabilities))
+ # The treatments names
+ treatments.label.plot <- names(ACProbabilities)
+
+ # What plot?
+ plot.it.to.image <- function(ACProbabilities, WTP, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Curva de Aceitabilidade"
+ xlabel <- "willingness-to-pay"
+ ylabel <- "Pr(INB > 0)"
+ ylim1 <- -0.1
+ ylim2 <- 1.1
+ plot(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ lines(WTP, ACProbabilities[,1],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ if (dim(ACProbabilities)[2] > 1) {
+ for (i in 2:dim(ACProbabilities)[2]) {
+ lines(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ points(WTP, ACProbabilities[,i],
+ col = treatments.colors.plot[i], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, ylim = c(ylim1,ylim2))
+ }
+ }
+
+ dev.off()
+ }
+ }
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(ACGraphWindow)
+ tkwm.deiconify(ACsimtableWindow)
+ tkfocus(ACsimtableWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(ACGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(ACProbabilities, WTP, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+ # posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ # tkconfigure(Export.but, state = "disabled")
+
+ tkbind(ACGraphWindow, "<Return>", OnOK)
+ tkbind(ACGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(ACGraphWindow)
+ tkfocus(ACGraphWindow)
+
+ }
+
+ OnAC(WTP, ans)
+
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(ACsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(Frame2,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(Frame2,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(ACsimtableWindow, "<Return>",OnOK)
+ tkbind(ACsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(ACsimtableWindow, 250, 310)
+
+ tkfocus(ACsimtableWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/acewindow.Rd
===================================================================
--- pkg/man/acewindow.Rd (rev 0)
+++ pkg/man/acewindow.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,166 @@
+\name{acewindow}
+\alias{acewindow}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+acewindow(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ require(abind)
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione o nodo de tipo 'Decisão' da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ if (( column != 1) && (node.number != 1)) {
+ msg <- paste("A tabela apresentada a seguir exibe resultados apenas para o nodo raiz.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+
+ CEtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(CEtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(CEtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ # Cria os elementos da lista
+ elementos <- Data.CEA$Node.name
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # Monta os frames
+ tkgrid(Frame1, Frame2, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = NA,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff. = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+
+ displayInTable(as.matrix(ans), title="Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(CEtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(CEtableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(CEtableWindow,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(CEtableWindow, "<Return>",OnOK)
+ tkbind(CEtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(CEtableWindow, 300, 180)
+
+ tkfocus(CEtableWindow)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/add.node.Rd
===================================================================
--- pkg/man/add.node.Rd (rev 0)
+++ pkg/man/add.node.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,128 @@
+\name{add.node}
+\alias{add.node}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+add.node(TheTree, node.col, node.number, node.name, node.prob, node.type = "C", node.notes = " ", node.destiny = " ", node.utility = 0, node.effectiveness = 0, playnumb = 2)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{node.col}{ ~~Describe \code{node.col} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{node.name}{ ~~Describe \code{node.name} here~~ }
+ \item{node.prob}{ ~~Describe \code{node.prob} here~~ }
+ \item{node.type}{ ~~Describe \code{node.type} here~~ }
+ \item{node.notes}{ ~~Describe \code{node.notes} here~~ }
+ \item{node.destiny}{ ~~Describe \code{node.destiny} here~~ }
+ \item{node.utility}{ ~~Describe \code{node.utility} here~~ }
+ \item{node.effectiveness}{ ~~Describe \code{node.effectiveness} here~~ }
+ \item{playnumb}{ ~~Describe \code{playnumb} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, node.col, node.number, node.name, node.prob, node.type = "C",
+ node.notes = " ", node.destiny = " ", node.utility = 0, node.effectiveness = 0,
+ playnumb = 2) {
+ require(abind)
+
+ variables <- names(TheTree)
+
+ num.col <- dim(TheTree)[2]
+ num.lin <- dim(TheTree)[1]
+
+ Levelmax <- max(TheTree$Level)
+ new.node.level <- node.col + 1
+
+ Data.father <- subset(TheTree, Level == node.col, select = variables)
+ Data.father <- subset(Data.father, Node.N == node.number, select = variables)
+ father.name <- Data.father$Node.name[1]
+
+ if(new.node.level <= Levelmax) {
+ Data <- subset(TheTree, Level == new.node.level, select = variables)
+ new.node.number <- max(Data$Node.N) + 1
+ } else {
+ new.node.number <- 1
+ }
+
+ Payoffs <- matrix(c(0,1), 1, playnumb)
+
+ colnames(Payoffs) <- paste("Payoff",1:length(Payoffs),sep="")
+
+ ans <- data.frame( Level = new.node.level, Node.N = new.node.number, Node.name = node.name,
+ Father = node.number, Father.Name = father.name,
+ Prob = node.prob, Type = node.type, Note = node.notes, Destiny = node.destiny,
+ Payoff1 = node.utility, Payoff2 = node.effectiveness)
+ ans <- abind(TheTree, ans, along=1)
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) < as.numeric(ans$Node.N[i-1]) ) &&
+ ( as.numeric(ans$Level[i]) == as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i-1]
+ ans$Node.N[i-1] <- ans$Node.N[i]
+ ans$Node.N[i] <- old.value
+ usedlevel <- ans$Level[i-1] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- old.value
+ ans$Father.Name[position] <- ans$Node.name[i-1]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+
+ rownames(ans) <- NULL
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/addnodewindows.Rd
===================================================================
--- pkg/man/addnodewindows.Rd (rev 0)
+++ pkg/man/addnodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,140 @@
+\name{addnodewindows}
+\alias{addnodewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+addnodewindows()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ node.col <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ if (node.type == "T") {
+ msg <- paste(" O nodo selecionado é de tipo 'Terminal'.\n Altere o tipo do nodo e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ # A janela Tk
+ addnodeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Novo Nodo"
+ tkwm.title(addnodeWindow,title)
+
+ NomeVar <- tclVar("New Node")
+ NomeEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=NomeVar)
+ tkgrid(tklabel(addnodeWindow,text="Nome do nodo"))
+ tkgrid(NomeEntryWidget)
+
+ ProbabilidadeVar <- tclVar("0.0")
+ ProbabilityEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=ProbabilidadeVar)
+ tkgrid(tklabel(addnodeWindow,text="Probabilidade"))
+ tkgrid(ProbabilityEntryWidget)
+
+ UtilidadeVar <- tclVar("0.0")
+ UtilityEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=UtilidadeVar)
+ tkgrid(tklabel(addnodeWindow,text="Custo / Payoff"))
+ tkgrid(UtilityEntryWidget)
+
+ EffectivenessVar <- tclVar("0.0")
+ EffectivenessEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=EffectivenessVar)
+ tkgrid(tklabel(addnodeWindow,text="Efetividade / Payoff"))
+ tkgrid(EffectivenessEntryWidget)
+
+ NotasVar <- tclVar(" ")
+ NotesEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=NotasVar)
+ tkgrid(tklabel(addnodeWindow,text="Notas"))
+ tkgrid(NotesEntryWidget)
+
+ tkfocus(addnodeWindow)
+
+ OnOK <- function()
+ {
+ NameVal <- tclvalue(NomeVar)
+ ProbabilidadeVal <- as.numeric( tclvalue(ProbabilidadeVar) )
+ UtilidadeVal <- as.numeric( tclvalue(UtilidadeVar) )
+ EffectivenessVal <- as.numeric( tclvalue(EffectivenessVar) )
+ NotasVal <- tclvalue(NotasVar)
+
+ if ( (ProbabilidadeVal < 0) || (ProbabilidadeVal > 1) ) {
+ msg <- paste("Este não é um valor de probabilidade válido '",ProbVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(addnodeWindow)
+ } else {
+ NewTree <- add.node(TheTree,
+ node.col = node.col,
+ node.number = node.number,
+ node.name = NameVal,
+ node.prob = ProbabilidadeVal,
+ node.type = "C",
+ node.notes = NotasVal,
+ node.destiny = " ",
+ node.utility = UtilidadeVal,
+ node.effectiveness = EffectivenessVal)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setaddnode(NewTree, .EnvironmentArvoRe)
+ refreshF5()
+ tkdestroy(addnodeWindow)
+ tkfocus(tt)
+ }
+
+ }
+ OK.but <-tkbutton(addnodeWindow,text=" OK ",command=OnOK)
+ tkbind(NomeEntryWidget, "<Return>",OnOK)
+ tkbind(ProbabilidadeVar, "<Return>",OnOK)
+ tkbind(UtilityEntryWidget, "<Return>",OnOK)
+ tkbind(EffectivenessEntryWidget, "<Return>",OnOK)
+ tkbind(NotasVar, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(addnodeWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(addnodeWindow,text=" Cancel ",command=OnCancel)
+ tkbind(addnodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(addnodeWindow, 250, 230)
+ }
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/arvore.Rd
===================================================================
--- pkg/man/arvore.Rd (rev 0)
+++ pkg/man/arvore.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,560 @@
+\name{arvore}
+\alias{arvore}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+arvore(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ # Se .ArvoReRunning existe, então o ÁrvoRe já está em execução...
+ if (!exists(".ArvoReRunning", envir = globalenv() )) {
+ # ArvoRe Settings
+ library(tcltk)
+ ###############################################################################
+ # THE GAME!!
+ ###############################################################################
+ # Configuration variables
+ .EnvironmentArvoRe <- globalenv()
+ .EnvironmentArvore.Secure <- new.env(parent = globalenv())
+ .arvore.version <- "Alfa-0.1.4" # The ArvoRe version
+ .arvore.release.date <- "June 18, 2008 06:43:29 PM " # The ArvoRe version date
+ .modeltypeArvore <- "CE" # Default calculation method "Simple" # "CEA"
+ .workstatus <- "saved" # File status
+ .opennedfile <- "newfile" # File name
+ .digits <- 3 # Decimal places
+ .init.objects <- objects(all.names = TRUE,
+ envir = .EnvironmentArvoRe) # Objetos existentes antes de abrir o ArvoRe
+ .treeangle <- "squared" # Tipo de ângulos exibidos para a árvore
+ .notesconf <- 0 # Mostrar notas no gráfico { 1 = yes, 0 = no }
+ .probabilityconf <- 1 # Mostrar probabilidades no gráfico { 1 = yes, 0 = no }
+ .payoffsconf <- 1 # Mostrar payoffs no gráfico { 1 = yes, 0 = no }
+ .node.name.font.size <- 12 # Tamanho da fonte para o nome do nodo exibido no gráfico.
+ .payoffs.font.size <- 8 # Tamanho da fonte para payoffs do nodo exibido no gráfico.
+ .notes.font.size <- 6 # Tamanho da fonte para comentários do nodo exibido no gráfico.
+ .absorventstateconf <- 1 # Estados absorventes da cadeia de Markov são interpretados como MORTE.
+
+ assign(".EnvironmentArvoRe", .EnvironmentArvoRe, env = .GlobalEnv)
+ assign(".EnvironmentArvore.Secure", .EnvironmentArvore.Secure, env = .GlobalEnv)
+ assign(".arvore.version", .arvore.version, env = .GlobalEnv)
+ assign(".modeltypeArvore", .modeltypeArvore, env = .GlobalEnv)
+ assign(".workstatus", .workstatus, env = .GlobalEnv)
+ assign(".opennedfile", .opennedfile, env = .GlobalEnv)
+ assign(".digits", .digits, env = .GlobalEnv)
+ assign(".init.objects", .init.objects, env = .GlobalEnv)
+ assign(".treeangle", .treeangle, env = .GlobalEnv)
+ assign(".notesconf", .notesconf, env = .GlobalEnv)
+ assign(".probabilityconf", .probabilityconf, env = .GlobalEnv)
+ assign(".payoffsconf", .payoffsconf, env = .GlobalEnv)
+ assign(".node.name.font.size", .node.name.font.size, env = .GlobalEnv)
+ assign(".node.name.font.size", .node.name.font.size, env = .GlobalEnv)
+ assign(".payoffs.font.size", .payoffs.font.size, env = .GlobalEnv)
+ assign(".notes.font.size", .notes.font.size, env = .GlobalEnv)
+ assign(".absorventstateconf", .absorventstateconf, env = .GlobalEnv)
+# assign("", x, env = .GlobalEnv)
+
+ ###############################################################################
+ # The Tk things
+ ###############################################################################
+ carregaTclpath() # Carrega extensões da Tcltk
+ tclRequire("Img")
+ tclRequire("BWidget")
+ #----------------------------------------------------------------------
+ # tclRequire("Tk") # Used in TckTk 8.5
+
+ # Create a new decision tree
+ new.tree()
+
+ # Set Running flag to TRUE
+ .ArvoReRunning <- TRUE
+
+ # The splashscreen
+ splashscreenArvoRe()
+
+ # The main window
+ tt <- tktoplevel()
+
+ # Send tt addres to .EnvironmentArvoRe
+ assign("tt", tt, .EnvironmentArvoRe)
+
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ .Frametitle1 <- " Representação Gráfica da Árvore "
+ .Frametitle2 <- paste("ÁrvoRe - versão ", .arvore.version, " | ",
+ " | ", "Rodando no R ", getRversion(), " ",
+ sep="")
+ .Frametitle3 <- " Configuração de Nodo "
+
+ tkwm.title(tt, .Windowtitle)
+
+ # Set max and min size to main ArvoRe window
+ tkwm.minsize(tt,640,480)
+ tkwm.maxsize(tt,1024,768)
+
+ # The Frames
+ frameOverall <- tkframe(tt)
+ frameBottons <- tkframe(frameOverall,relief="groove",borderwidth=2)
+ frameUpper <- tkframe(frameOverall,relief="groove",borderwidth=2)
+
+ frameUpperLeft <- tkframe(frameUpper,relief="groove",borderwidth=2)
+
+ frameUpperLeftUp <- tkframe(frameUpperLeft,relief="groove",borderwidth=2)
+ frameUpperLeftDown <- tkframe(frameUpperLeft,relief="groove",borderwidth=2)
+
+ frameUpperRigth <- tkframe(frameUpper,relief="groove",borderwidth=2)
+ tkpack(tklabel(frameUpperRigth,text = .Frametitle1))
+
+ frameLower <- tkframe(frameOverall,relief="sunken",borderwidth=2)
+ tkpack(tklabel(frameLower,text = .Frametitle2, justify = "left"), fill = "x", expand = 0, side = "left")
+
+ tkpack(frameBottons, anchor = "nw", expand = 0, side = "top")#, fill = "x")
+ tkpack(frameUpperLeft, frameUpperRigth, side = "left", expand = 1, fill = "both")
+ tkpack(frameUpper, anchor = "n", side = "top", expand = 1, fill = "both")
+ tkpack(tklabel(frameOverall,text=" "))
+ tkpack(frameLower, anchor = "sw", fill = "x", expand = 0, side = "bottom")
+ tkpack(tklabel(frameOverall,text=" "))
+ tkpack(frameOverall, anchor = "center", expand = 1, fill = "both")
+
+ # The Menu
+ topMenu <- tkmenu(tt)
+ tkconfigure(tt,menu=topMenu)
+ fileMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(fileMenu,"command",label="Novo Ctrl+N",command=function() new.file.bot())
+ tkadd(fileMenu,"command",label="Abrir... Ctrl+O",command=function() load.file.arv())
+ tkadd(fileMenu,"command",label="Salvar Ctrl+S",command=function() save.file.arv())
+ tkadd(fileMenu,"command",label="Salvar como... Ctrl+Alt+S",command=function() save.as.file.arv())
+ tkadd(fileMenu,"separator")
+ tkadd(fileMenu,"command",label="Exportar... Ctrl+E",command=function() export.tree.graph())
+ tkadd(fileMenu,"separator")
+ tkadd(fileMenu,"command",label="Sair Esc",command=function() sair())
+ tkadd(topMenu,"cascade",label="Arquivo",menu=fileMenu)
+
+ editMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(editMenu,"command",label="Desfazer",command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tkadd(editMenu,"command",label="Refazer",command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Recortar",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Copiar",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Colar",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Excluir",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Recortar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Copiar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"command",label="Colar sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Excluir sub-árvore",command=function() naoimplementado())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Variáveis...",command=function() dialog.variable.window())
+ tkadd(editMenu,"separator")
+ tkadd(editMenu,"command",label="Configurações",command=function() properties.tree())
+ tkadd(topMenu,"cascade",label="Editar",menu=editMenu)
+
+ modelMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(modelMenu,"command",label="Árvore de decisão simples",command=function() set.model.type("SD") )
+ tkadd(modelMenu,"separator")
+ tkadd(modelMenu,"command",label="Árvore de decisão Custo-Efetividade",command=function() set.model.type("CE") )
+
+ tkadd(topMenu,"cascade",label="Modelo",menu=modelMenu)
+
+ analysisMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(analysisMenu,"command",label="Valores esperados (Roll Back)",command=function() show.summary.rollback.window())
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Resumo da ACE (ICER)...",command=function() acewindow(TheTree))
+ tkadd(analysisMenu,"command",label="Plano Custo-Efetividade",command=function() planoacewindow(TheTree))
+ tkadd(analysisMenu,"command",label="Net Benefit (INB)",command=function() inbwindow(TheTree))
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Resumo da árvore",command=function() show.summary.tree.window())
+ tkadd(analysisMenu,"separator")
+ tkadd(analysisMenu,"command",label="Verificar probabilidades",command=function() show.prob.check.window(TheTree))
+ tkadd(topMenu,"cascade",label="Análise",menu=analysisMenu)
+
+ windowMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(windowMenu,"command",label="Zoom +...",command=function() zoom.in.but(imgHeight))
+ tkadd(windowMenu,"command",label="Zoom -...",command=function() zoom.out.but(imgHeight))
+ tkadd(windowMenu,"separator")
+ tkadd(windowMenu,"command",label="Resolução da janela...",command=function() naoimplementado())
+ tkadd(topMenu,"cascade",label="Janela",menu=windowMenu)
+
+ helpMenu <- tkmenu(topMenu,tearoff=FALSE)
+ tkadd(helpMenu,"command",label="Ajuda",command=function() help.start())
+ tkadd(helpMenu,"separator")
+ tkadd(helpMenu,"command",label="Sobre o programa",command=function() sobre(.arvore.version, .arvore.release.date))
+ tkadd(topMenu,"cascade",label="Ajuda",menu=helpMenu)
+
+ # The top bottons
+ .Height.but <- 3
+ .Width.but <- 7
+ .Height.img.but <- 32
+ .Width.img.but <- 32
+
+ # New button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/New.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ new.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but,
+ command=function() new.file.bot())
+ tcl("DynamicHelp::add", new.but, "-type", "balloon", "-text", "Novo trabalho")
+
+ } else {
+ new.but <- tkbutton(frameBottons, text="Novo", width=.Width.but, height=.Height.but, command=function() new.file.bot())
+ tcl("DynamicHelp::add", new.but, "-type", "balloon", "-text", "Novo trabalho")
+ }
+ }
+
+ # Open button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Open.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ open.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() load.file.arv())
+ tcl("DynamicHelp::add", open.but, "-type", "balloon", "-text", "Abrir trabalho")
+ } else {
+ open.but <- tkbutton(frameBottons, text="Abrir", width=.Width.img.but, height=.Height.img.but, command=function() load.file.arv())
+ tcl("DynamicHelp::add", open.but, "-type", "balloon", "-text", "Abrir trabalho")
+ }
+ }
+
+ # Save button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Save.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ save.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() save.file.arv())
+ tcl("DynamicHelp::add", save.but, "-type", "balloon", "-text", "Salvar o trabalho atual")
+ } else {
+ save.but <- tkbutton(frameBottons, text="Salvar", width=.Width.img.but, height=.Height.img.but, command=function() save.file.arv())
+ tcl("DynamicHelp::add", save.but, "-type", "balloon", "-text", "Salvar o trabalho atual")
+
+ }
+ }
+
+ # Save As button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/SaveAs.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ saveas.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() save.as.file.arv())
+ tcl("DynamicHelp::add", saveas.but, "-type", "balloon", "-text", "Salvar como...")
+ } else {
+ saveas.but <- tkbutton(frameBottons, text="Salvar \n como...", width=.Width.img.but, height=.Height.img.but, command=function() save.as.file.arv())
+ tcl("DynamicHelp::add", saveas.but, "-type", "balloon", "-text", "Salvar como...")
+ }
+ }
+
+ # Undo button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Undo.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ undo.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", undo.but, "-type", "balloon", "-text", "Desfazer")
+ } else {
+ undo.but <- tkbutton(frameBottons, text="<=", width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", undo.but, "-type", "balloon", "-text", "Desfazer")
+ }
+ }
+
+
+ # Redo button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Redo.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ redo.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", redo.but, "-type", "balloon", "-text", "Refazer")
+ } else {
+ redo.but <- tkbutton(frameBottons, text="=>", width=.Width.img.but, height=.Height.img.but, command=function() changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure))
+ tcl("DynamicHelp::add", redo.but, "-type", "balloon", "-text", "Refazer")
+ }
+ }
+
+ # Markov properties button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Markov.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ markov.prop.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() markov.nodes.properties(TheTree, .EnvironmentArvoRe))
+ tcl("DynamicHelp::add", markov.prop.but, "-type", "balloon", "-text", "Propriedades do estado Markov...")
+ } else {
+ markov.prop.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() markov.nodes.properties(TheTree, .EnvironmentArvoRe))
+ tcl("DynamicHelp::add", markov.prop.but, "-type", "balloon", "-text", "Propriedades do estado Markov...")
+ }
+ }
+
+ # Variable button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Variable.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ variable.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() dialog.variable.window())
+ tcl("DynamicHelp::add", variable.but, "-type", "balloon", "-text", "Variáveis...")
+ } else {
+ variable.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() dialog.variable.window())
+ tcl("DynamicHelp::add", variable.but, "-type", "balloon", "-text", "Variáveis...")
+ }
+ }
+
+ # Simulation button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Simulation.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ simulation.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() dialog.simulation.window())
+ tcl("DynamicHelp::add", simulation.but, "-type", "balloon", "-text", "Simular... (MCMC)")
+ } else {
+ simulation.but <- tkbutton(frameBottons, text="Markov \n Sim.", width=.Width.img.but, height=.Height.img.but, command=function() dialog.simulation.window())
+ tcl("DynamicHelp::add", simulation.but, "-type", "balloon", "-text", "Simular... (MCMC)")
+ }
+ }
+
+ # Roll-Back button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Ball.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rollback.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() show.summary.rollback.window())
+ tcl("DynamicHelp::add", rollback.but, "-type", "balloon", "-text", "Roll-back")
+ } else {
+ rollback.but <- tkbutton(frameBottons, text="Roll-Back", width=.Width.img.but, height=.Height.img.but, command=function() show.summary.rollback.window())
+ tcl("DynamicHelp::add", rollback.but, "-type", "balloon", "-text", "Roll-back")
+ }
+ }
+
+ # Sensitivity Analysis button 1-way
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Graph.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ sa.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sa.1way.window())
+ tcl("DynamicHelp::add", sa.but, "-type", "balloon", "-text", "Análise de Sensibilidade 1-way")
+ } else {
+ sa.but <- tkbutton(frameBottons, text="Análise de Sensibilidade 1-way", width=.Width.img.but, height=.Height.img.but, command=function() sa.1way.window())
+ tcl("DynamicHelp::add", sa.but, "-type", "balloon", "-text", "Análise de Sensibilidade 1-way")
+ }
+ }
+
+ # Sensitivity Analysis button 2-way
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Graph2.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ sa2.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sa.2way.window())
+ tcl("DynamicHelp::add", sa2.but, "-type", "balloon", "-text", "Análise de Sensibilidade 2-way")
+ } else {
+ sa2.but <- tkbutton(frameBottons, text="Análise de Sensibilidade 2-way", width=.Width.img.but, height=.Height.img.but, command=function() sa.2way.window())
+ tcl("DynamicHelp::add", sa2.but, "-type", "balloon", "-text", "Análise de Sensibilidade 2-way")
+ }
+ }
+
+ # Zoom In button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/ZoomPlus.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ zoom.in <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() zoom.in.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.in, "-type", "balloon", "-text", "Aumentar zoom")
+ } else {
+ zoom.in <- tkbutton(frameBottons, text="Zoom \n +", width=.Width.img.but, height=.Height.img.but, command=function() zoom.in.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.in, "-type", "balloon", "-text", "Aumentar zoom")
+ }
+ }
+
+
+ # Zoom Out button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/ZoomMinus.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ zoom.out <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() zoom.out.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.out, "-type", "balloon", "-text", "Diminuir zoom")
+ } else {
+ zoom.out <- tkbutton(frameBottons, text="Zoom \n -", width=.Width.img.but, height=.Height.img.but, command=function() zoom.out.but(imgHeight))
+ tcl("DynamicHelp::add", zoom.out, "-type", "balloon", "-text", "Diminuir zoom")
+ }
+ }
+
+
+ # Exit button
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Exit.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ exit.but <- tkbutton(frameBottons, image=icn, width=.Width.img.but, height=.Height.img.but, command=function() sair())
+ tcl("DynamicHelp::add", exit.but, "-type", "balloon", "-text", "Sair do programa")
+ } else {
+ exit.but <- tkbutton(frameBottons, text="Sair", width=.Width.img.but, height=.Height.img.but, command=function() sair())
+ tcl("DynamicHelp::add", exit.but, "-type", "balloon", "-text", "\"Sair do programa \"")
+ }
+ }
+
+ separator1 <- tklabel(frameBottons, text = " ")
+ separator2 <- tklabel(frameBottons, text = " ")
+ separator3 <- tklabel(frameBottons, text = " ")
+ separator4 <- tklabel(frameBottons, text = " ")
+ separator5 <- tklabel(frameBottons, text = " ")
+ separator6 <- tklabel(frameBottons, text = " ")
+
+ tkgrid(new.but, open.but, save.but, saveas.but, separator1,
+ undo.but, redo.but, separator2,
+ markov.prop.but, variable.but, separator3,
+ simulation.but, rollback.but, separator4,
+ sa.but, sa2.but, separator5,
+ zoom.in, zoom.out, separator6,
+ exit.but,
+ sticky = "nw")
+
+ tkconfigure(new.but, activebackground = "white")
+ tkflash(new.but)
+
+ # The tree structure view
+
+ xScr <- tkscrollbar(frameUpperLeftUp,command=function(...)tkxview(treeWidget,...),orient="horizontal")
+ yScr <- tkscrollbar(frameUpperLeftUp,command=function(...)tkyview(treeWidget,...))
+ treeWidget <- tkwidget(frameUpperLeftUp,"Tree", deltax = 25, deltay = 20,
+ xscrollcommand=function(...)tkset(xScr,...),
+ yscrollcommand=function(...)tkset(yScr,...),
+ width=30,height=15)
+ tkgrid(treeWidget, yScr)
+ tkgrid.configure(treeWidget,stick="nswe")
+ tkgrid.configure(yScr,stick="nsw")
+ tkgrid(xScr)
+ tkgrid.configure(xScr,stick="nswe")
+
+ tkgrid(frameUpperLeftUp, sticky = "nwe")
+
+ # Send treeWidget addres to .EnvironmentArvoRe
+ assign("treeWidget", treeWidget, .EnvironmentArvoRe)
+
+ theTreeTkArvore(TheTree)
+
+ # The Tree Bottons
+ .Height.but <- 2
+ .Width.but <- 16
+
+ node.name.but <- tkbutton(frameUpperLeftDown, text="Nome", width=.Width.but, height=.Height.but, command=function() nodenamewindows())
+ node.prob.but <- tkbutton(frameUpperLeftDown, text="Probabilidade", width=.Width.but, height=.Height.but, command=function() probwindows())
+ node.playoff.but <- tkbutton(frameUpperLeftDown, text="Valores", width=.Width.but, height=.Height.but, command=function() utilitywindows())
+ node.type <- tkbutton(frameUpperLeftDown, text="Tipo", width=.Width.but, height=.Height.but, command=function() typenodewindows())
+ node.add <- tkbutton(frameUpperLeftDown, text="Adicionar", width=.Width.but, height=.Height.but, command=function() addnodewindows())
+ node.remove <- tkbutton(frameUpperLeftDown, text="Remover", width=.Width.but, height=.Height.but, command=function() removenodewindows())
+ node.destiny <- tkbutton(frameUpperLeftDown, text="Destino", width=.Width.but, height=.Height.but, command=function() destinynodewindows())
+ node.notes <- tkbutton(frameUpperLeftDown, text="Comentários", width=.Width.but, height=.Height.but, command=function() notesnodewindows())
+
+ tkgrid(tklabel(frameUpperLeft,text = .Frametitle3))
+ tkgrid(node.name.but, row = 0, column = 0, sticky = "nw")
+ tkgrid(node.prob.but, row = 0, column = 1, sticky = "nw")
+ tkgrid(node.type, row = 1, column = 0, sticky = "nw")
+ tkgrid(node.playoff.but, row = 1, column = 1, sticky = "nw")
+ tkgrid(node.add, row = 2, column = 0, sticky = "nw")
+ tkgrid(node.remove, row = 2, column = 1, sticky = "nw")
+ tkgrid(node.destiny, row = 3, column = 0, sticky = "nw")
+ tkgrid(node.notes, row = 3, column = 1, sticky = "nw")
+
+ tkgrid(frameUpperLeftDown, sticky = "swe") #, side = "bottom", expand = 1, fill = "both")
+
+ # Image window configurations
+ Height <- 400
+ Width <- 600
+ Borderwidth <- 2
+
+ # scrollbar objects
+ Hscroll <- tkscrollbar(frameUpperRigth, orient="horiz", command = function(...)tkxview(Canvas,...) )
+ Vscroll <- tkscrollbar(frameUpperRigth, command = function(...)tkyview(Canvas,...) )
+ Canvas <- tkcanvas(frameUpperRigth, relief = "sunken", borderwidth = Borderwidth,
+ width = Width, height = Height,
+ xscrollcommand = function(...)tkset(Hscroll,...),
+ yscrollcommand = function(...)tkset(Vscroll,...)
+ )
+
+ assign("Canvas", Canvas, .EnvironmentArvoRe)
+
+ # Pack the scroll bars.
+ tkpack(Hscroll, side = "bottom", fill = "x")
+ tkpack(Vscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(Canvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image setings.
+ imgHeight <- 600
+ imgWidth <- 800
+
+ assign("imgHeight", imgHeight, .EnvironmentArvoRe)
+ assign("imgWidth", imgWidth, .EnvironmentArvoRe)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "arvore.png", sep="")
+
+ # unlink(x, recursive = FALSE)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(Canvas, "image", imgWidth/2, imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(Canvas, scrollregion = c(0,0,imgWidth,imgHeight))
+ file.remove(.Filename)
+
+
+ ###############################################################################
+ # The keys
+ ###############################################################################
+
+ tkbind(tt, "<Escape>",sair)
+ tkbind(tt, "<Control_L><n>",new.file.bot)
+ tkbind(tt, "<Control_L><o>",load.file.arv)
+ tkbind(tt, "<Control_L><Alt_L><s>",save.file.arv)
+ tkbind(tt, "<Control_L><s>",save.file.arv)
+ tkbind(tt, "<Control_L><e>",naoimplementado)
+ tkbind(tt, "<F5>",refreshF5)
+
+
+ ###############################################################################
+
+ posiciona.janela.tela(tt)
+ tkfocus(tt)
+ tkwm.deiconify(tt)
+ } else {
+ msg <- paste("O programa ÁrvoRe já está sendo executado.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/atualiza.grafico.Rd
===================================================================
--- pkg/man/atualiza.grafico.Rd (rev 0)
+++ pkg/man/atualiza.grafico.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,61 @@
+\name{atualiza.grafico}
+\alias{atualiza.grafico}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+atualiza.grafico(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ .Filename <- paste(tempdir(),"\\", "arvore.png", sep="")
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(Canvas, "image", imgWidth/2, imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(Canvas, scrollregion = c(0,0,imgWidth,imgHeight))
+
+ file.remove(.Filename)
+ tkwm.deiconify(tt)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/carregaTclpath.Rd
===================================================================
--- pkg/man/carregaTclpath.Rd (rev 0)
+++ pkg/man/carregaTclpath.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,43 @@
+\name{carregaTclpath}
+\alias{carregaTclpath}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+carregaTclpath()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ addTclPath("C:/Tcl/lib")
+ addTclPath("C:/Arquivos de programas/Tcl/lib")
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/changedofunction.Rd
===================================================================
--- pkg/man/changedofunction.Rd (rev 0)
+++ pkg/man/changedofunction.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,56 @@
+\name{changedofunction}
+\alias{changedofunction}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+changedofunction(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.modeltypeArvore}{ ~~Describe \code{.modeltypeArvore} here~~ }
+ \item{.EnvironmentArvore.Secure}{ ~~Describe \code{.EnvironmentArvore.Secure} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .modeltypeArvore, .EnvironmentArvore.Secure) {
+ TheTree.old <- TheTree
+ .EnvironmentArvoRe.old <- .EnvironmentArvoRe
+ .modeltypeArvore.old <- .modeltypeArvore
+
+ assign("TheTree", get("TheTree", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+ assign(".EnvironmentArvoRe", get(".EnvironmentArvoRe", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+ assign(".modeltypeArvore", get(".modeltypeArvore", .EnvironmentArvore.Secure), .EnvironmentArvoRe)
+
+ safedofunction(TheTree.old, .EnvironmentArvoRe.old, .modeltypeArvore.old)
+ refreshF5()
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/clearTreeTkArvore.Rd
===================================================================
--- pkg/man/clearTreeTkArvore.Rd (rev 0)
+++ pkg/man/clearTreeTkArvore.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,50 @@
+\name{clearTreeTkArvore}
+\alias{clearTreeTkArvore}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+clearTreeTkArvore(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ i <- TheTree$Level
+ j <- TheTree$Node.N
+
+ osnodos <- paste(i,".",j,sep="")
+ tkdelete(treeWidget,osnodos[j])
+ tkdelete(treeWidget,"1.1")
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/convert2matrix.Rd
===================================================================
--- pkg/man/convert2matrix.Rd (rev 0)
+++ pkg/man/convert2matrix.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,162 @@
+\name{convert2matrix}
+\alias{convert2matrix}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+convert2matrix(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+
+ n.levels <- max(TheTree$Level)
+
+ x <- matrix(NA, 0, n.levels)
+ y <- matrix(NA, 0, n.levels)
+ probMAT <- matrix(NA, 0, n.levels)
+ typeMAT <- matrix(NA, 0, n.levels)
+ effectivenessMAT <- matrix(NA, 0, n.levels)
+ utilityMAT <- matrix(NA, 0, n.levels)
+ destinyMAT <- matrix(NA, 0, n.levels)
+
+ for (i in n.levels:1) {
+ Data.level <- TheTree[TheTree$Level == i,]
+ nodes <- as.numeric(levels(as.factor(Data.level$Node.N)))
+
+ line.x <- array(NA, n.levels)
+ line.y <- array(NA, n.levels)
+ line.prob <- array(1, n.levels)
+ line.type <- array(NA, n.levels)
+ line.effectiveness <- array(1, n.levels)
+ line.utility <- array(0, n.levels)
+ line.destiny <- array(NA, n.levels)
+
+ for (j in nodes) {
+ if (sum( x[,i] == j, na.rm = TRUE ) < 1) {
+ Data.Node <- Data.level[ Data.level$Node.N == j,]
+
+ father.node <- as.numeric(Data.Node$Father[1])
+ label.father <- Data.Node$Father.Name[1]
+
+ line.x[i] <- j
+ line.y[i] <- Data.Node$Node.name[1]
+ line.prob[i] <- Data.Node$Prob[1]
+ line.type[i] <- Data.Node$Type[1]
+ line.effectiveness[i] <- as.numeric(as.character(Data.Node$Payoff2[1]))
+ line.utility[i] <- as.numeric(as.character(Data.Node$Payoff1[1]))
+ line.destiny[i] <- Data.Node$Destiny[1]
+
+
+ if (i > 1) {
+ for (k in (i-1):1) {
+ line.x[k] <- father.node
+ line.y[k] <- label.father
+
+ Data.node.return <- TheTree[TheTree$Level == k,]
+ Data.node.return <- Data.node.return[Data.node.return$Node.N == as.character(line.x[k]),]
+ father.node <- as.numeric(Data.node.return$Father[1])
+ label.father <- Data.node.return$Father.Name
+ prob.father <- Data.node.return$Prob
+ type.father <- Data.node.return$Type
+ effectiveness.father <- Data.node.return$Payoff2[1]
+ utility.father <- Data.node.return$Payoff1[1]
+ destiny.father <- Data.node.return$Destiny
+
+ line.prob[k] <- prob.father
+ line.type[k] <- type.father
+ line.effectiveness[k] <- as.numeric(as.character(effectiveness.father))
+ line.utility[k] <- as.numeric(as.character(utility.father))
+ line.destiny[k] <- destiny.father
+
+ }
+ }
+ x <- rbind(x,line.x)
+ y <- rbind(y,line.y)
+ probMAT <- rbind(probMAT,line.prob)
+ typeMAT <- rbind(typeMAT,line.type)
+ effectivenessMAT <- rbind(effectivenessMAT,line.effectiveness)
+ utilityMAT <- rbind(utilityMAT,line.utility)
+ destinyMAT <- rbind(destinyMAT,line.destiny)
+ }
+ }
+ }
+
+# ordena as matrizes para nao haver problema com a plot.tree - June 21, 2008
+ for (i in 1:dim(x)[2]) {
+ if ( sum(is.na(x[,i])) == 0 ) { # whatcolorder <- c(whatcolorder, i)
+ y <- y[order(x[,i]),]
+ probMAT <- probMAT[order(x[,i]),]
+ typeMAT <- typeMAT[order(x[,i]),]
+ effectivenessMAT <- effectivenessMAT[order(x[,i]),]
+ utilityMAT <- utilityMAT[order(x[,i]),]
+ destinyMAT <- destinyMAT[order(x[,i]),]
+ x <- x[order(x[,i]),]
+ }
+ }
+
+ x <- as.matrix(x)
+ y <- as.matrix(y)
+ probMAT <- as.matrix(probMAT)
+ typeMAT <- as.matrix(typeMAT)
+ effectivenessMAT <- as.matrix(effectivenessMAT)
+ utilityMAT <- as.matrix(utilityMAT)
+ destinyMAT <- as.matrix(destinyMAT)
+
+ colnames(x) <- NULL
+ rownames(x) <- NULL
+ colnames(y) <- NULL
+ rownames(y) <- NULL
+ colnames(probMAT) <- NULL
+ rownames(probMAT) <- NULL
+ colnames(typeMAT) <- NULL
+ rownames(typeMAT) <- NULL
+ colnames(effectivenessMAT) <- NULL
+ rownames(effectivenessMAT) <- NULL
+ colnames(utilityMAT) <- NULL
+ rownames(utilityMAT) <- NULL
+ colnames(destinyMAT) <- NULL
+ rownames(destinyMAT) <- NULL
+
+ dl <- dim(destinyMAT)[1]
+ destinyarray <- array(0,dl)
+ for (i in 1:dl) {
+ balde <- destinyMAT[i, !is.na(destinyMAT[i,]) ]
+ destinyarray[i] <- balde[length(balde)]
+ }
+ ans <- list( x = x, y = y, probMAT = probMAT, typeMAT = typeMAT, effectivenessMAT = effectivenessMAT,
+ utilityMAT = utilityMAT, destinyMAT = destinyarray)
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/cost.effectiveness.table.Rd
===================================================================
--- pkg/man/cost.effectiveness.table.Rd (rev 0)
+++ pkg/man/cost.effectiveness.table.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,116 @@
+\name{cost.effectiveness.table}
+\alias{cost.effectiveness.table}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+cost.effectiveness.table(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+ x <- Matrixset$x
+ y <- Matrixset$y
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+ typeMAT <- Matrixset$typeMAT
+
+ rollbackLIST <- rollback(TheTree)
+
+ num.col <- dim(x)[2]
+ num.lin <- dim(x)[1]
+
+ levelnode <- array(,0)
+ paispos <- array(,0)
+ nnode <- array(,0)
+ namenode <- array(,0)
+ probnode <- array(,0)
+ utilitynode <- array(,0)
+ effectivenessnode <- array(,0)
+ typenode <- array(,0)
+ paisnodos.n <- array(,0)
+ paisnodos.name <- array(,0)
+ paisnodos <- array(,0)
+ expectedvalue.cost <- array(,0)
+ expectedvalue.effectiveness <- array(,0)
+ expectedvalue.ce <- array(,0)
+
+ for (i in 1:num.col) {
+ max.node <- max(x[,i], na.rm = TRUE)
+ pais <- 1:max.node
+ for (k in pais) {
+ levelnode <- c(levelnode,i)
+ nodepos <- which(x[,i] == k)[1]
+ paispos <- c(paispos, nodepos)
+ if (i == 1) {
+ paisnodos.n <- c(paisnodos.n, 1)
+ paisnodos.name <- c(paisnodos.name, " ")
+ } else {
+ paisnodos.n <- c(paisnodos.n, x[nodepos, i-1])
+ paisnodos.name <- c(paisnodos.name, y[nodepos, i-1])
+ }
+ nnode <- c(nnode, k)
+ namenode <- c(namenode, y[nodepos, i])
+ probnode <- c(probnode, probMAT[nodepos, i])
+ utilitynode <- c(utilitynode, utilityMAT[nodepos, i])
+ effectivenessnode <- c(effectivenessnode, effectivenessMAT[nodepos, i])
+ typenode <- c(typenode, typeMAT[nodepos, i])
+ expectedvalue.cost <- c(expectedvalue.cost, rollbackLIST[["Cost"]][nodepos, i])
+ expectedvalue.effectiveness <- c(expectedvalue.effectiveness, rollbackLIST[["Effectiveness"]][nodepos, i])
+ expectedvalue.ce <- c(expectedvalue.ce, rollbackLIST[["CE"]][nodepos, i])
+
+ }
+ }
+
+ tabela <- data.frame(Level = levelnode, Node.N = nnode, Node.name = namenode,
+ Mean.Cost = expectedvalue.cost,
+ Mean.Effectiveness = expectedvalue.effectiveness,
+ Mean.C.E.ratio = expectedvalue.ce
+ )
+
+ tabela <- subset(tabela, Level == 2)
+ tabela <- as.data.frame(tabela)
+
+ tabela$Level <- as.numeric(tabela$Level)
+ tabela$Node.N <- as.numeric(tabela$Node.N)
+ tabela$Node.name <- as.character(tabela$Node.name)
+ tabela$Mean.Cost <- as.numeric(as.numeric(tabela$Mean.Cost))
+ tabela$Mean.Effectiveness <- as.numeric(as.numeric(tabela$Mean.Effectiveness))
+ tabela$Mean.C.E.ratio <- as.numeric(as.numeric(tabela$Mean.C.E.ratio))
+
+ return(tabela)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/destinynodewindows.Rd
===================================================================
--- pkg/man/destinynodewindows.Rd (rev 0)
+++ pkg/man/destinynodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,141 @@
+\name{destinynodewindows}
+\alias{destinynodewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+destinynodewindows(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( .modeltypeArvore != "CE") {
+ msg <- paste(" Você não está utilizando um modelo Markov.\n Altere o tipo de modelo para poder definir destino a um nodo.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ node.type <- TheTree$Type[position]
+
+
+ if (node.type == "T") {
+ node.Origins <- select.origins(TheTree, node.col = column, node.number = node.number)
+ position.exist.markov <- which(node.Origins$Type == "M")
+
+ if (length(position.exist.markov) > 0) {
+ destinyWindow <- tktoplevel()
+ title <- "ÁrvoRe - Destino do Nodo"
+ tkwm.title(destinyWindow,title)
+
+ position.exist.markov <- max(position.exist.markov)
+ column.markov <- node.Origins$Level[position.exist.markov]
+ number.markov.node <- node.Origins$Node.N[position.exist.markov]
+
+ k <- subset(TheTree, Level == column.markov + 1)
+ k <- subset(k, Father == number.markov.node)
+ k <- k[union( which(k$Type == "C"), which(k$Type == "T")), ]
+
+ markov.nodes <- as.character(k$Node.name)
+ markov.nodes.position <- as.numeric(k$Node.N)
+ markov.nodes.col <- as.numeric(k$Level)
+
+ heightlistbox <- length(markov.nodes)
+
+ scr <- tkscrollbar(destinyWindow, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ tl <- tklistbox(destinyWindow,height=heightlistbox,selectmode="single",
+ yscrollcommand=function(...)tkset(scr,...),background="white")
+ tkgrid(tklabel(destinyWindow,text="Seleciona um nodo de destino"))
+ tkgrid(tl,scr)
+ tkgrid.configure(scr,rowspan=4,sticky="nsw")
+
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl,"end",markov.nodes[i])
+ }
+
+ if(TheTree$Destiny[position[1]] != " ") {
+ selected <- which( markov.nodes.position == as.numeric(TheTree$Destiny[position[1]]))
+ tkselection.set(tl,selected-1)
+ }
+
+ OnOK <- function()
+ {
+ destinyChoice <- markov.nodes.position[as.numeric(tkcurselection(tl))+1]
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ TheTree$Destiny[position] <- destinyChoice
+ setdestinynode(TheTree, .EnvironmentArvoRe)
+ tkdestroy(destinyWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(destinyWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(destinyWindow,text=" OK ",command=OnOK)
+ tkbind(destinyWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(destinyWindow,text=" Cancel ",command=OnCancel)
+ tkbind(destinyWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(destinyWindow, 230, 150)
+
+ tkfocus(destinyWindow)
+ } else {
+ msg <- paste("O nodo selecionado não é um nodo de transição de um nodo tipo 'Markov'. \n Apenas nodos desse tipo podem seguir um destino.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ } else {
+ msg <- paste("O nodo selecionado não é um nodo do tipo 'Terminal'. \n Apenas nodos desse tipo podem seguir um destino.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+
+ }
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/dialog.simulation.window.Rd
===================================================================
--- pkg/man/dialog.simulation.window.Rd (rev 0)
+++ pkg/man/dialog.simulation.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,433 @@
+\name{dialog.simulation.window}
+\alias{dialog.simulation.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+dialog.simulation.window(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ .begin.sim <- TRUE # Servirá como flag para se saber se se pode iniciar a simulação.
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ .begin.sim <- FALSE
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ }
+ TestPartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)$Type
+ position.test <- which( TestPartialTree == "M" )
+ if (length(position.test) > 0) {
+ if (dim(markov.propertiesMAT)[1] == 0) {
+ msg <- paste("Propriedades dos nodos representantes dos estados Markov não \n",
+ "foram definidos. Use o botão 'M' para ajustar as propriedades \n",
+ "destes nodos.", sep = "")
+ tkmessageBox(message = msg, icon="error", title = "ÁrvoRe - AVISO")
+ .begin.sim <- FALSE
+ tkfocus(tt)
+ }
+ }
+ if (.begin.sim) {
+ if (node.type == "M") {
+############ MARKOV ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Markov Simulation"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Individuosvar <- tclVar(10000)
+ Terminalvar <- tclVar("(.stage >= 10)")
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Individuos.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Individuosvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Individuos.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+ Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Condição de término da simulação"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Terminal.Value, row = 5, column = 0, columnspan = 2, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ IndividuosVal <- as.integer(tclvalue(Individuosvar))
+ TerminalVal <- as.character(tclvalue(Terminalvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(IndividuosVal)) && (!is.na(IndividuosVal)) && (nchar(IndividuosVal) > 0) ) {
+ PartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)
+ Partialmarkov.propertiesMAT <- select.markov.propertiesMAT(TheTree, PartialTree, markov.propertiesMAT)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Mktable <- markov.coort.table(PartialTree, Partialmarkov.propertiesMAT, markov.termination = TerminalVal,
+ initial.coort = IndividuosVal, seed = SeedVal, absorventstatedeath = .absorventstateconf)
+ tempo2 <- Sys.time()
+# assign("Mktable", Mktable, .EnvironmentArvoRe)
+ Mktable <- list(Mktable)
+ names(Mktable) <- TheTree$Node.name[position]
+ summary.simulation.window(Mktable,
+ tempo1 = tempo1,
+ tempo2 = tempo2,
+ CicloVal = dim(Mktable)[1],
+ tipo.nodo = "M",
+ digits = .digits)
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",IndividuosVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Individuos.Value, "<Return>",OnOK)
+ tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 250, 200)
+# tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "D") {
+############ DECISION ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Markov Simulation"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Individuosvar <- tclVar(10000)
+ Terminalvar <- tclVar("(.stage >= 10)")
+ Trialssvar <- tclVar(10000)
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Individuos.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Individuosvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte (Markov) \n Número de repetições (random walk) (Chance/Terminal)"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Individuos.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+ Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Condição de término da simulação"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Terminal.Value, row = 5, column = 0, columnspan = 2, sticky = "n")
+
+# Trialss.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Trialssvar)
+# tkgrid(tklabel(dialogsimulationwindow,text="Número de repetições (random walk)"),
+# row = 6, column = 0, columnspan = 2, sticky = "n")
+# tkgrid(Trialss.Value, row = 7, column = 0, columnspan = 2, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ IndividuosVal <- as.integer(tclvalue(Individuosvar))
+ TerminalVal <- as.character(tclvalue(Terminalvar))
+ TrialssVal <-IndividuosVal
+# TrialssVal <- as.integer(tclvalue(Trialssvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(IndividuosVal)) && (!is.na(IndividuosVal)) && (nchar(IndividuosVal) > 0) ) {
+ nodestoSim <- subset(TheTree, Level == column + 1)
+ nodestoSim <- subset(nodestoSim, Father == node.number)
+
+ Times.to.sim.init <- array(,0)
+ Times.to.sim.final <- array(,0)
+
+ Names.to.sim <- array(,0)
+ Types.to.sim <- array(,0)
+
+ Sim.list.to.resume <- list()
+
+ for ( nodeinquestion in 1:length(nodestoSim$Node.N) ) {
+ nodegotosim.Type <- nodestoSim$Type[nodeinquestion]
+ nodegotosim.Name <- nodestoSim$Node.name[nodeinquestion]
+ nodegotosim.Node.N <- nodestoSim$Node.N[nodeinquestion]
+ nodegotosim.Level <- nodestoSim$Level[nodeinquestion]
+
+ if ( nodegotosim.Type == "M") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ Partialmarkov.propertiesMAT <- select.markov.propertiesMAT(TheTree,
+ PartialTree,
+ markov.propertiesMAT)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- markov.coort.table(PartialTree,
+ markov.propertiesMAT = Partialmarkov.propertiesMAT,
+ markov.termination = TerminalVal,
+ initial.coort = IndividuosVal,
+ seed = SeedVal,
+ absorventstatedeath = .absorventstateconf)
+ tempo2 <- Sys.time()
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "M")
+ }
+ if ( nodegotosim.Type == "C") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- simple.markov.coort.table(PartialTree,
+ trials = TrialssVal,
+ seed = SeedVal)
+ tempo2 <- Sys.time()
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "C")
+ }
+ if ( nodegotosim.Type == "T") {
+ PartialTree <- select.subtree(TheTree,
+ node.col = nodegotosim.Level,
+ node.number = nodegotosim.Node.N,
+ change.row.names = FALSE)
+ Times.to.sim.init <- c(Times.to.sim.init, Sys.time())
+ Sim.list.to.resume[[nodeinquestion]] <- terminal.markov.coort.table(PartialTree, trials = TrialssVal)
+ Times.to.sim.final <- c(Times.to.sim.final, Sys.time())
+ Names.to.sim <- c(Names.to.sim, nodegotosim.Name)
+ Types.to.sim <- c(Types.to.sim, "T")
+# cat("NODO Terminal : fazendo nada | dialog.simulation() \n")
+ }
+ }
+ names(Sim.list.to.resume) <- Names.to.sim
+ summary.simulation.window(Sim.list.to.resume,
+ tempo1 = Times.to.sim.init,
+ tempo2 = Times.to.sim.final,
+ CicloVal = 999,
+ tipo.nodo = Types.to.sim,
+ digits = .digits)
+
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",IndividuosVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Individuos.Value, "<Return>",OnOK)
+ tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 300, 200)
+ # tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "C") {
+############ CHANCE ############
+ dialogsimulationwindow <- tktoplevel()
+ title <- "ÁrvoRe - Markov Simulation"
+ tkwm.title(dialogsimulationwindow,title)
+
+ Seedvar <- tclVar(0)
+ Trialssvar <- tclVar(10000)
+# Terminalvar <- tclVar("(.stage >= 10)")
+
+ Seed.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Seedvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Semente (zero indica semente não determinada)"),
+ row = 0, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Seed.Value, row = 1, column = 0, columnspan = 2, sticky = "n")
+
+ Trialss.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Trialssvar)
+ tkgrid(tklabel(dialogsimulationwindow,text="Número de repetições (random walk)"),
+ row = 2, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(Trialss.Value, row = 3, column = 0, columnspan = 2, sticky = "n")
+
+# Terminal.Value <- tkentry(dialogsimulationwindow,width="20",textvariable=Terminalvar)
+# tkgrid(tklabel(dialogsimulationwindow,text="Número de indivíduos na coorte"), sticky = "n")
+# tkgrid(Terminal.Value, sticky = "n")
+
+ tkgrid(tklabel(dialogsimulationwindow,text=" "), columnspan = 2, sticky = "n")
+
+ OnOK <- function()
+ {
+ tkconfigure(dialogsimulationwindow,cursor="watch") # faz com que o cursor mude para busy
+
+ SeedVal <- as.integer(tclvalue(Seedvar))
+ TrialssVal <- as.integer(tclvalue(Trialssvar))
+# TerminalVal <- as.character(tclvalue(Terminalvar))
+
+ if ( (is.numeric(SeedVal)) && (!is.na(SeedVal)) && (nchar(SeedVal) > 0) ) {
+ if ( (is.numeric(TrialssVal)) && (!is.na(TrialssVal)) && (nchar(TrialssVal) > 0) ) {
+ PartialTree <- select.subtree(TheTree, node.col = column, node.number = node.number, change.row.names = FALSE)
+ if (SeedVal == 0) SeedVal <- FALSE
+ tempo1 <- Sys.time()
+ Mktable <- simple.markov.coort.table(PartialTree, trials = TrialssVal, seed = SeedVal)
+ tempo2 <- Sys.time()
+# assign("Mktable", Mktable, .EnvironmentArvoRe)
+ Mktable <- list(Mktable)
+ names(Mktable) <- TheTree$Node.name[position]
+ summary.simulation.window(Mktable,
+ tempo1 = tempo1,
+ tempo2 = tempo2,
+ CicloVal = dim(Mktable)[1],
+ tipo.nodo = "C",
+ digits = .digits)
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor válido para o número de de indivíduos na coorte '",TrialssVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ } else {
+ msg <- paste("Este não é um valor válido para o número de ciclos '",CicloVal, "'")
+ tkmessageBox(message=msg)
+ tkconfigure(dialogsimulationwindow,cursor="arrow")
+ tkfocus(dialogsimulationwindow)
+ }
+ }
+
+ OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK)
+
+ tkbind(Seed.Value, "<Return>",OnOK)
+ tkbind(Trialss.Value, "<Return>",OnOK)
+# tkbind(Terminal.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(dialogsimulationwindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel)
+ tkbind(dialogsimulationwindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ posiciona.janela.no.mouse(dialogsimulationwindow, 250, 150)
+ # tcl("tkwait","window",dialogsimulationwindow)
+ tkfocus(dialogsimulationwindow)
+ } else {
+ if (node.type == "T") {
+############ TERMINAL ############
+ msg <- paste("O nodo selecionado é do tipo 'Terminal'. Selecione um outro \n nodo da árvore para executar simulação.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+#
+# PartialTree <- select.subtree(TheTree,
+# node.col = column, node.number = node.number,
+# change.row.names = FALSE)
+# tempo1 <- Sys.time()
+# Mktable <- terminal.markov.coort.table(PartialTree)
+# print(Mktable)
+# tempo2 <- Sys.time()
+# summary.simulation.window(Mktable,
+# tempo1 = tempo1,
+# tempo2 = tempo2,
+# CicloVal = dim(Mktable)[1],
+# tipo.nodo = "M",
+# digits = .digits)
+ } else {
+ cat("ERROR: Tipo não reconhecido \n")
+ msg <- paste("O nodo selecionado é de tipo não reconhecido. Selecione um outro \n nodo da árvore para executar simulação.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+ }
+ }
+
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/dialog.variable.window.Rd
===================================================================
--- pkg/man/dialog.variable.window.Rd (rev 0)
+++ pkg/man/dialog.variable.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,360 @@
+\name{dialog.variable.window}
+\alias{dialog.variable.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+dialog.variable.window(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ if (!exists("variableMAT",.EnvironmentArvoRe)) new.variable.list() # se não existe uma tabela de variaveis, então ele cria.
+
+ variableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(variableWindow,title)
+
+ frameOverall <- tkframe(variableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=2)
+
+ scrvar <- tkscrollbar(frameUpperRigth, repeatinterval=5,
+ command=function(...)tkyview(tlvar,...))
+ tlvar <- tklistbox(frameUpperRigth,height=4,selectmode="single",
+ yscrollcommand=function(...)tkset(scrvar,...),background="white")
+ tkgrid(tklabel(frameUpperRigth,text="Variáveis"))
+ tkgrid(tlvar,scrvar)
+ tkgrid.configure(scrvar,rowspan=4,sticky="nsw")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="nsw")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ variablesnames <- variableMAT[,1]
+
+ if (length(variablesnames) > 0) {
+ for (i in (1:length(variablesnames))) {
+ tkinsert(tlvar,"end",variablesnames[i])
+ }
+ }
+
+ AddSelection <- function()
+ {
+ addvariableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(addvariableWindow,title)
+
+ frameOverall <- tkframe(addvariableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameOverall,text="Nova Variável"))
+
+ Namevar <- tclVar("")
+ Fixvar <- tclVar(0)
+ Minvar <- tclVar(0)
+ Maxvar <- tclVar(0)
+ Notesvar <- tclVar("")
+
+ campowidth <- 25
+ Name.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Namevar)
+ tkgrid(tklabel(frameUpper,text="Nome da variável"), sticky = "n")
+ tkgrid(Name.var.Value, sticky = "n")
+
+ Fix.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Fixvar)
+ tkgrid(tklabel(frameUpper,text="Valor padrão da variável"), sticky = "n")
+ tkgrid(Fix.var.Value, sticky = "n")
+
+ Min.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Minvar)
+ tkgrid(tklabel(frameUpper,text="Valor mínimo da variável"), sticky = "n")
+ tkgrid(Min.var.Value, sticky = "n")
+
+ Max.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Maxvar)
+ tkgrid(tklabel(frameUpper,text="Valor máximo da variável"), sticky = "n")
+ tkgrid(Max.var.Value, sticky = "n")
+
+ Notes.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Notesvar)
+ tkgrid(tklabel(frameUpper,text="Notas"), sticky = "n")
+ tkgrid(Notes.var.Value, sticky = "n")
+
+ OnOkAdd <- function() {
+ Allok <- TRUE
+ NameVal <- as.character(tclvalue(Namevar))
+ FixVal <- as.integer(tclvalue(Fixvar))
+ MinVal <- as.integer(tclvalue(Minvar))
+ MaxVal <- as.integer(tclvalue(Maxvar))
+ NotesVal <- as.character(tclvalue(Notesvar))
+
+ if((nchar(NameVal) <= 0)&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um nome válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(FixVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor fixo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MinVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor mínimo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MaxVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor máximo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((MinVal >= MaxVal)&& Allok) {
+ Allok <- FALSE
+ msg <- "O valor mínimo de uma variável deve ser menor que o valor máximo."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if(Allok) {
+ newvariableline <- data.frame(Name = NameVal, Fix.Value = FixVal, Min.Value = MinVal,
+ Max.Value = MaxVal, Notes = NotesVal)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline, action = "add")
+ tkinsert(tlvar,"end",NameVal)
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ }
+
+ OnCanceladd <- function() {
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOkAdd)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCanceladd)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(addvariableWindow, "<Return>",OnOkAdd)
+ tkbind(addvariableWindow, "<Escape>",OnCanceladd)
+
+ tkfocus(addvariableWindow)
+ }
+
+ DeleteSelection <- function()
+ {
+ variableIndex <- as.integer(tkcurselection(tlvar))
+ variableslist <- variableMAT$Name
+ variabletodelete <- as.character(variableslist[variableIndex+1])
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setvariablelist(variableMAT = variableMAT, variable.name = variabletodelete, action = "delete")
+ tkdelete(tlvar,variableIndex)
+ tkfocus(variableWindow)
+ }
+
+ EditSelection <- function()
+ {
+ variableIndex <- as.integer(tkcurselection(tlvar))
+
+ variableslist <- variableMAT$Name
+ variableselected <- as.character(variableslist[variableIndex+1])
+
+ addvariableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Variáveis"
+ tkwm.title(addvariableWindow,title)
+
+ frameOverall <- tkframe(addvariableWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameOverall,text="Propriedades da Variável"))
+
+ variableMATnames <- names(variableMAT)
+ Data <- subset(variableMAT, Name == variableselected, select = variableMATnames)
+
+ Namevar <- tclVar(Data$Name)
+ Fixvar <- tclVar(Data$Fix.Value)
+ Minvar <- tclVar(Data$Min.Value)
+ Maxvar <- tclVar(Data$Max.Value)
+ Notesvar <- tclVar(Data$Notes)
+
+ campowidth <- 25
+ Name.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Namevar)
+ tkgrid(tklabel(frameUpper,text="Nome da variável"), sticky = "n")
+ tkgrid(Name.var.Value, sticky = "n")
+
+ Fix.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Fixvar)
+ tkgrid(tklabel(frameUpper,text="Valor padrão da variável"), sticky = "n")
+ tkgrid(Fix.var.Value, sticky = "n")
+
+ Min.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Minvar)
+ tkgrid(tklabel(frameUpper,text="Valor mínimo da variável"), sticky = "n")
+ tkgrid(Min.var.Value, sticky = "n")
+
+ Max.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Maxvar)
+ tkgrid(tklabel(frameUpper,text="Valor máximo da variável"), sticky = "n")
+ tkgrid(Max.var.Value, sticky = "n")
+
+ Notes.var.Value <- tkentry(frameUpper, width=campowidth,textvariable=Notesvar)
+ tkgrid(tklabel(frameUpper,text="Notas"), sticky = "n")
+ tkgrid(Notes.var.Value, sticky = "n")
+
+ OnOkAdd <- function() {
+ Allok <- TRUE
+ NameVal <- as.character(tclvalue(Namevar))
+ FixVal <- as.integer(tclvalue(Fixvar))
+ MinVal <- as.integer(tclvalue(Minvar))
+ MaxVal <- as.integer(tclvalue(Maxvar))
+ NotesVal <- as.character(tclvalue(Notesvar))
+
+ if((nchar(NameVal) <= 0)&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um nome válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(FixVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor fixo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MinVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor mínimo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((!is.numeric(MaxVal))&& Allok) {
+ Allok <- FALSE
+ msg <- "Este não é um valor máximo válido para uma variável."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if((MinVal >= MaxVal)&& Allok) {
+ Allok <- FALSE
+ msg <- "O valor mínimo de uma variável deve ser menor que o valor máximo."
+ tkmessageBox(message = msg, icon="error")
+ tkfocus(addvariableWindow)
+ }
+ if(Allok) {
+ oldvariable.name <- Data$Name
+ newvariableline <- data.frame(Name = NameVal, Fix.Value = FixVal, Min.Value = MinVal,
+ Max.Value = MaxVal, Notes = NotesVal)
+
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ if (length(oldvariable.name) == 0) {
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline,
+ action = "add")
+ oldvariable.name <- " "
+ } else {
+ setvariablelist(variableMAT = variableMAT, newvariableline = newvariableline,
+ variable.name = oldvariable.name, action = "edit")
+ }
+
+ if (oldvariable.name != NameVal) {
+ if (oldvariable.name != " ") tkdelete(tlvar,variableIndex)
+ tkinsert(tlvar,"end",NameVal)
+ }
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ }
+
+ OnCanceladd <- function() {
+ tkdestroy(addvariableWindow)
+ tkfocus(variableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOkAdd)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCanceladd)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(addvariableWindow, "<Return>",OnOkAdd)
+ tkbind(addvariableWindow, "<Escape>",OnCanceladd)
+
+ tkfocus(addvariableWindow)
+
+ }
+
+ OnOK <- function()
+ {
+ tkdestroy(variableWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameOverall,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Edit.but <-tkbutton(frameUpperLeft,text="Editar", width=.Width.but, height=.Height.but,command=EditSelection)
+ Add.but <-tkbutton(frameUpperLeft,text="Nova", width=.Width.but, height=.Height.but,command=AddSelection)
+ Delete.but <-tkbutton(frameUpperLeft,text="Apagar", width=.Width.but, height=.Height.but,command=DeleteSelection)
+
+ tkbind(variableWindow, "<Return>",OnOK)
+ tkbind(variableWindow, "<Escape>",OnOK)
+
+ tkgrid(OK.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Add.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Delete.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Edit.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameOverall)
+
+ posiciona.janela.no.mouse(variableWindow, 250, 160)
+
+ tkfocus(variableWindow)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/dimensoes.janela.Rd
===================================================================
--- pkg/man/dimensoes.janela.Rd (rev 0)
+++ pkg/man/dimensoes.janela.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,68 @@
+\name{dimensoes.janela}
+\alias{dimensoes.janela}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+dimensoes.janela(janela, height, width)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{janela}{ ~~Describe \code{janela} here~~ }
+ \item{height}{ ~~Describe \code{height} here~~ }
+ \item{width}{ ~~Describe \code{width} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(janela, height, width) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela) ) )
+
+ wm.x <- as.integer( tclvalue( tkwinfo("x", janela) ) )
+ wm.y <- as.integer( tclvalue( tkwinfo("y", janela) ) )
+
+ if( height > MAX.height ) height <- MAX.height
+ if( width > MAX.width ) width <- MAX.width
+
+ limite.sup.x <- round( MAX.width - width )
+ limite.inf.x <- round( width )
+ limite.sup.y <- round( MAX.height - height )
+ limite.sup.y <- round( height )
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$\%#$\%
+ if (wm.x > limite.sup.x) wm.x <- limite.sup.x
+ if (wm.x < limite.inf.x) wm.x <- limite.inf.x
+ if (wm.y > limite.sup.y) wm.y <- limite.sup.y
+ if (wm.y > limite.sup.y) wm.y <- limite.sup.y
+
+ posicao <- paste(width, "x", height, "+", wm.x,"+", wm.y, sep="")
+ tkwm.geometry(janela,posicao)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/displayInTable.Rd
===================================================================
--- pkg/man/displayInTable.Rd (rev 0)
+++ pkg/man/displayInTable.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,230 @@
+\name{displayInTable}
+\alias{displayInTable}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+displayInTable(matrix1, title = "", height = -1, width = -1, nrow = -1, ncol = -1, titlerows = FALSE, titlecols = FALSE, editable = FALSE, returntt = TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{matrix1}{ ~~Describe \code{matrix1} here~~ }
+ \item{title}{ ~~Describe \code{title} here~~ }
+ \item{height}{ ~~Describe \code{height} here~~ }
+ \item{width}{ ~~Describe \code{width} here~~ }
+ \item{nrow}{ ~~Describe \code{nrow} here~~ }
+ \item{ncol}{ ~~Describe \code{ncol} here~~ }
+ \item{titlerows}{ ~~Describe \code{titlerows} here~~ }
+ \item{titlecols}{ ~~Describe \code{titlecols} here~~ }
+ \item{editable}{ ~~Describe \code{editable} here~~ }
+ \item{returntt}{ ~~Describe \code{returntt} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(matrix1,title="",height=-1,width=-1,nrow=-1,ncol=-1,
+ titlerows = FALSE, titlecols = FALSE, editable = FALSE,
+ returntt = TRUE) {
+ require(tcltk)
+
+ Original.Dada <- matrix1
+
+ num.lin <- dim(matrix1)[1]
+ num.col <- dim(matrix1)[2]
+
+ if (titlecols && (!titlerows)) {
+ TitleCols <- colnames(matrix1)
+ if (is.null(colnames(matrix1))) TitleCols <- paste("Col ", 1:num.col, sep="")
+ matrix1 <- rbind(TitleCols, matrix1)
+ nrow <- nrow + 1
+ }
+
+ if ( titlerows && (!titlecols) ) {
+ TitleRows <- rownames(matrix1)
+ if (is.null(rownames(matrix1))) TitleRows <- paste("Row ", 1:num.lin, sep="")
+ matrix1 <- cbind(TitleRows, matrix1)
+ ncol <- ncol + 1
+ } else {
+ if ( titlerows && titlecols ) {
+ TitleCols <- colnames(matrix1)
+ if (is.null(colnames(matrix1))) TitleCols <- paste("Col ", 1:num.col, sep="")
+ matrix1 <- rbind(TitleCols, matrix1)
+ TitleRows <- rownames(matrix1)
+ if (is.null(rownames(matrix1))) TitleRows <- paste("Row ", 1:num.lin, sep="")
+ TitleRows <- c(" ", TitleRows)
+ matrix1 <- cbind(TitleRows, matrix1)
+ ncol <- ncol + 1
+ nrow <- nrow + 1
+ }
+ }
+
+ num.lin <- dim(matrix1)[1]
+ num.col <- dim(matrix1)[2]
+
+# remover se nao funcionar
+ matrix1 <- matrix(as.character(matrix1), num.lin, num.col)
+#---------------------------
+
+# tamanhocoluna <- max(nchar(matrix1))
+
+ tclarray <- tclArray()
+ for (i in (1:num.lin))
+ for (j in (1:num.col))
+ tclarray[[i-1,j-1]] <- matrix1[i,j]
+
+ if( editable ) {
+ editable <- "normal"
+ } else {
+ editable <- "disabled"
+ }
+
+ displayInTableWindow <- tktoplevel()
+ tclRequire("Tktable")
+ tkwm.title(displayInTableWindow,title)
+
+ table1 <- tkwidget(displayInTableWindow,"table",rows=nrow,cols=ncol,
+ titlerows = sum(titlecols), titlecols = sum(titlerows),
+ height=height+1,width=width+1,
+ xscrollcommand=function(...) tkset(xscr,...),yscrollcommand=function(...) tkset(yscr,...),
+ state = editable,
+ colstretchmode = "all")
+# colwidth = tamanhocoluna)
+ xscr <-tkscrollbar(displayInTableWindow,orient="horizontal", command=function(...)tkxview(table1,...))
+ yscr <- tkscrollbar(displayInTableWindow,command=function(...)tkyview(table1,...))
+
+ tkgrid(table1, yscr, columnspan = 2)
+
+ tkgrid.configure(yscr, sticky="nsw")
+ tkgrid.configure(table1, sticky="nswe")
+
+ tkgrid(xscr, sticky="new", columnspan = 2)
+
+ tkconfigure(table1,variable=tclarray,background="white",selectmode="extended")
+
+ OnExport <- function(Original.Dada) {
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(filetypeWindow)
+ else {
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ tkfocus(displayInTableWindow)
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(displayInTableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+
+ OnOK <- function() {
+ tkdestroy(displayInTableWindow)
+ if (returntt) {
+ tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(displayInTableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <-tkbutton(displayInTableWindow,text="Exportar", width=.Width.but, height=.Height.but, command=function() {OnExport(Original.Dada)})
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(displayInTableWindow, "<Return>",OnOK)
+ tkbind(displayInTableWindow, "<Escape>",OnOK)
+
+ tkfocus(displayInTableWindow)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/exec.text.Rd
===================================================================
--- pkg/man/exec.text.Rd (rev 0)
+++ pkg/man/exec.text.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,46 @@
+\name{exec.text}
+\alias{exec.text}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+exec.text(x)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ ~~Describe \code{x} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(x) {
+ ans <- try( eval(parse(text = x)) )
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/export.global.Rd
===================================================================
--- pkg/man/export.global.Rd (rev 0)
+++ pkg/man/export.global.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,46 @@
+\name{export.global}
+\alias{export.global}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+export.global(x, nome)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{ ~~Describe \code{x} here~~ }
+ \item{nome}{ ~~Describe \code{nome} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(x, nome) {
+ assign(nome, x, env = .GlobalEnv)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/export.tree.graph.Rd
===================================================================
--- pkg/man/export.tree.graph.Rd (rev 0)
+++ pkg/man/export.tree.graph.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,197 @@
+\name{export.tree.graph}
+\alias{export.tree.graph}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+export.tree.graph(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+
+ exportgraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportgraphWindow,title)
+
+ frameOverall <- tkframe(exportgraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function()
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ png(file=.Filename, width = imgWidth, height = imgHeight, bg = "white", restoreConsole = FALSE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ jpeg(filename = .Filename, width = imgWidth, height = imgHeight,
+ units = "px", pointsize = 12, quality = ImgQualityselected, bg = "white",
+ res = NA, restoreConsole = TRUE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(tt)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ bmp(filename = .Filename, width = imgWidth, height = imgHeight,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = TRUE)
+ plot.tree(TheTree, line.type = .treeangle, show.probability = .probabilityconf,
+ show.payoffs = .payoffsconf, show.notes = .notesconf,
+ node.name.font.size = .node.name.font.size, payoffs.font.size = .payoffs.font.size,
+ notes.font.size = .notes.font.size)
+ dev.off()
+
+ }
+ }
+ }
+ tkdestroy(exportgraphWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportgraphWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportgraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportgraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportgraphWindow)
+ posiciona.janela.no.mouse(exportgraphWindow)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/icer.sim.window.Rd
===================================================================
--- pkg/man/icer.sim.window.Rd (rev 0)
+++ pkg/man/icer.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,189 @@
+\name{icer.sim.window}
+\alias{icer.sim.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+icer.sim.window(Alltreatmentstable)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Alltreatmentstable}{ ~~Describe \code{Alltreatmentstable} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(Alltreatmentstable) {
+ require(abind)
+
+ CEsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(CEsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(CEsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # Monta os frames
+ tkgrid(Frame1, Frame2, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+ ans <- data.frame( Strategy = Data.standart.Cost$Treatment[1],
+ Cost = Data.standart.Cost$Mean[1],
+ Incr.Cost = NA,
+ Effectiveness = Data.standart.Effectiveness$Mean[1],
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart.Cost$Mean[1] / Data.standart.Effectiveness$Mean[1],
+ ICER = NA,
+ Var.ICER = NA,
+ Sd.ICER = NA,
+ LL_IC95 = NA,
+ UL_IC95 = NA
+ )
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ icer <- (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1]) /
+ (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1])
+
+ var.icer <- ( icer
+ ) *
+ (
+ ( Data.alternative.Effectiveness$Variance[i] / Data.alternative.Effectiveness$Mean[i]^2 ) +
+ ( Data.alternative.Cost$Variance[i] / Data.alternative.Cost$Mean[i]^2 ) -
+ 2 * ( 00000 ) /
+ ( Data.alternative.Effectiveness$Mean[i] / Data.alternative.Cost$Mean[i] )
+ )
+
+ ans.line <- data.frame( Strategy = Data.alternative.Cost$Treatment[i],
+ Cost = Data.alternative.Cost$Mean[i],
+ Incr.Cost = Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1],
+ Effectiveness = Data.alternative.Effectiveness$Mean[i],
+ Incr.Eff. = Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1],
+ CE.ratio = Data.alternative.Cost$Mean[i] / Data.alternative.Effectiveness$Mean[i],
+ ICER = icer,
+ Var.ICER = var.icer,
+ Sd.ICER = var.icer^0.5,
+ LL_IC95 = icer - qnorm(1 - 0.05/2) * var.icer^0.5,
+ UL_IC95 = icer + qnorm(1 - 0.05/2) * var.icer^0.5
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+
+# print(ans)
+
+ displayInTable(as.matrix(ans), title="ICER - Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(CEsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(CEsimtableWindow,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(CEsimtableWindow,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(CEsimtableWindow, "<Return>",OnOK)
+ tkbind(CEsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(CEsimtableWindow, 300, 180)
+
+ tkfocus(CEsimtableWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/inb.sim.window.Rd
===================================================================
--- pkg/man/inb.sim.window.Rd (rev 0)
+++ pkg/man/inb.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,197 @@
+\name{inb.sim.window}
+\alias{inb.sim.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+inb.sim.window(Alltreatmentstable)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Alltreatmentstable}{ ~~Describe \code{Alltreatmentstable} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(Alltreatmentstable) {
+ require(abind)
+
+ INBsimtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - INB"
+ tkwm.title(INBsimtableWindow,title)
+
+ # Cria o primeiro frame
+ FrameOverAll <- tkframe(INBsimtableWindow, borderwidth = 0, relief = "groove")
+ Frame1 <- tkframe(FrameOverAll, borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(FrameOverAll, borderwidth = 0, relief = "sunken")
+
+ # Cria o label
+ textlabellista <- "Selecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais."
+ rotulolista <- tklabel(Frame1, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(Frame1, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ Data.CEA <- Alltreatmentstable
+ Data.CEA.Cost <- subset(Data.CEA, Data == "Cost")
+ Data.CEA.Effectiveness <- subset(Data.CEA, Data == "Effectiveness")
+ Data.CEA.CE <- subset(Data.CEA, Data == "C/E")
+ n.treat <- 1:length(Data.CEA.Cost$Treatment)
+
+ Data.CEA.Cost <- data.frame(NT = n.treat, Data.CEA.Cost)
+ Data.CEA.Effectiveness <- data.frame(NT = n.treat, Data.CEA.Effectiveness)
+ Data.CEA.CE <- data.frame(NT = n.treat, Data.CEA.CE)
+
+# print(Data.CEA.Cost)
+# print(Data.CEA.Effectiveness)
+# print(Data.CEA.CE)
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA.Cost$Treatment
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(Frame1, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+ # The WTP
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(Frame1,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(Frame1,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(Frame1,text=" "),
+ columnspan = 2, sticky = "n")
+
+ # Monta os frames
+ tkgrid(Frame1, sticky = "nwe", padx = 5, pady = 5)
+ tkgrid(Frame2, sticky = "s", padx = 5, pady = 5)
+ tkgrid(FrameOverAll, sticky = "nswe", columnspan = 2)
+
+ OnOK <- function() {
+ respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1]
+ WTPVal <- as.integer(tclvalue(WTPvar))
+
+ Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox)
+ Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox)
+ Data.alternative.Effectiveness <- subset(Data.CEA.Effectiveness, NT != respostaListbox)
+ Data.standart.Effectiveness <- subset(Data.CEA.Effectiveness, NT == respostaListbox)
+ Data.alternative.CE <- subset(Data.CEA.CE, NT != respostaListbox)
+ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox)
+
+ ans <- data.frame( Strategy = Data.standart.Cost$Treatment[1],
+ Cost = Data.standart.Cost$Mean[1],
+ Incr.Cost = NA,
+ Effectiveness = Data.standart.Effectiveness$Mean[1],
+ Incr.Eff. = NA,
+ CE.ratio = Data.standart.Cost$Mean[1] / Data.standart.Effectiveness$Mean[1],
+ INB = NA,
+ Var.INB = NA,
+ Sd.INB = NA,
+ LL_IC95_INB = NA,
+ UL_IC95_INB = NA
+ )
+
+ for (i in 1:dim(Data.alternative.Cost)[1]) {
+
+ inb <- (Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1]) *
+ WTPVal - (Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1])
+ var.inb <- ( WTPVal^2
+ ) * Data.alternative.Effectiveness$Variance[i] +
+ Data.alternative.Cost$Variance[i] -
+ 2 * WTPVal * ( 00000 )
+ alfa <- 0.05 # the significance
+
+ ans.line <- data.frame( Strategy = Data.alternative.Cost$Treatment[i],
+ Cost = Data.alternative.Cost$Mean[i],
+ Incr.Cost = Data.alternative.Cost$Mean[i] - Data.standart.Cost$Mean[1],
+ Effectiveness = Data.alternative.Effectiveness$Mean[i],
+ Incr.Eff. = Data.alternative.Effectiveness$Mean[i] - Data.standart.Effectiveness$Mean[1],
+ CE.ratio = Data.alternative.Cost$Mean[i] / Data.alternative.Effectiveness$Mean[i],
+ INB = inb,
+ Var.INB = var.inb,
+ Sd.INB = var.inb^0.5,
+ LL_IC95_INB = inb - qnorm(1 - alfa/2) * var.inb^0.5,
+ UL_IC95_INB = inb + qnorm(1 - alfa/2) * var.inb^0.5
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+
+# print(ans)
+
+ displayInTable(as.matrix(ans), title="ICER - Análise de Custo-Efetividade",
+ height=10,width=8,nrow=dim(ans)[1],ncol=dim(ans)[2],
+ titlerows = FALSE, titlecols = TRUE, returntt = FALSE)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(INBsimtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(Frame2,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(Frame2,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(INBsimtableWindow, "<Return>",OnOK)
+ tkbind(INBsimtableWindow, "<Escape>",OnOK)
+
+ posiciona.janela.no.mouse(INBsimtableWindow, 250, 230)
+
+ tkfocus(INBsimtableWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/inbwindow.Rd
===================================================================
--- pkg/man/inbwindow.Rd (rev 0)
+++ pkg/man/inbwindow.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,684 @@
+\name{inbwindow}
+\alias{inbwindow}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+inbwindow(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ require(abind)
+
+ plotINBtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - INB"
+ tkwm.title(plotINBtableWindow,title)
+
+ # What plot?
+ frameOverall <- tkwidget(plotINBtableWindow, "labelframe", borderwidth = 0, relief = "groove",
+ labelanchor = "n")
+ frametext <- "Gráfico"
+ framePlot <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frametext <- "Propriedades"
+ frameProp <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(plotINBtableWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ # The data to plot
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ AllTreatCost <- Data.CEA$Mean.Cost
+ AllTreatEffectiveness <- Data.CEA$Mean.Effectiveness
+ AllTreatCE <- Data.CEA$Mean.Cost / Data.CEA$Mean.Effectiveness
+
+ # Initial WTP
+ WTParray <- seq(0, 10000, round( (10000 - 0 ) / 10) )
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(Data.CEA$Node.name)
+ # The treatments names
+ treatments.label.plot <- Data.CEA$Node.name
+
+ # Default img type
+ img.type <- "png"
+ img.quality <- 90
+
+ # The frame Properties
+ LIvar <- tclVar(0)
+ LSvar <- tclVar(10000)
+ NPvar <- tclVar(10)
+
+ label0 <- tklabel(frameProp,text = "Intervalo para o WTP (threshold)")
+ tkgrid(label0, columnspan = 2, stick = "n")
+
+ entry.ValueLI <- tkentry(frameProp,width="20",textvariable=LIvar)
+ label1 <- tklabel(frameProp,text="Limite inferior")
+ tkgrid(label1, entry.ValueLI, sticky = "n")
+
+ entry.ValueLS <- tkentry(frameProp,width="20",textvariable=LSvar)
+ label2 <- tklabel(frameProp,text="Limite superior")
+ tkgrid(label2, entry.ValueLS, sticky = "n")
+
+ entry.ValueNP <- tkentry(frameProp,width="20",textvariable=NPvar)
+ label3 <- tklabel(frameProp,text="Intervalos")
+ tkgrid(label3, entry.ValueNP, sticky = "n")
+
+ # Cria o label
+ textlabellista <- "\nSelecione o procedimento padrão para ACE. \n Ele será a base de comparação para os demais.\n"
+ rotulolista <- tklabel(frameProp, text = textlabellista)
+ tkgrid(rotulolista, columnspan = 2)
+
+ # Cria uma barra de rolagem
+ scr <- tkscrollbar(frameProp, repeatinterval=5, command=function(...)tkyview(tl,...))
+
+ # Cria os elementos da lista
+ elementos <- Data.CEA$Node.name
+
+ # Determina a altura da listbox
+ heightlistbox <- length(elementos)
+ larguratexto <- max(nchar(elementos)) + 4
+ # Cria uma listbox
+ tl <- tklistbox(frameProp, height = 5, width = larguratexto, selectmode = "single",
+ yscrollcommand = function(...)tkset(scr,...), background="white")
+
+ # Adiciona os elementos à listbox
+ for (i in (1:heightlistbox)) {
+ tkinsert(tl, "end", elementos[i])
+ }
+
+ # Monta a listbox e a barra de rolagem
+ tkgrid(tl, scr, sticky="nse")
+
+# tkgrid(tklabel(Frame1, text = " "))
+
+ # Ajusta a barra de rolagem
+ tkgrid.configure(scr, rowspan = 5, sticky="nsw")
+
+ # Define o "Elemento 2" como padrão da listbox.
+ # Para a listbox o índice começa em zero
+ tkselection.set(tl, 0)
+
+
+ # ---------------------------------------------------------------------------------------------------
+ tkgrid(framePlot, frameProp, sticky = "n")
+ tkgrid(frameOverall, sticky = "nwe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(framePlot, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(framePlot, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(framePlot, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvoreCE.png", sep="")
+
+
+ plot.it.to.image <- function(wtp, cedata, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 400, img.height = 400, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Incremental Net Benefit"
+ xlabel <- "Willingness-to-pay"
+ ylabel <- "INB"
+
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+ rownames(inb) <- cedata$Strategy
+# print(wtp)
+# print(inb)
+
+ xlim1 <- min(wtp)
+ xlim2 <- max(wtp)
+ ylim1 <- min(inb)
+ ylim2 <- max(inb)
+
+ plot(wtp, inb[1,],
+ col = treatments.colors.plot[1], pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel, xlim = c(xlim1,xlim2), ylim = c(ylim1,ylim2))
+ lines(wtp, inb[1,], col = treatments.colors.plot[1])
+ for (i in 2:dim(cedata)[1]) {
+ lines(wtp, inb[i,], col = treatments.colors.plot[i])
+ points(wtp, inb[i,], col = treatments.colors.plot[i], pch = "*")
+ }
+ dev.off()
+ }
+ }
+ }
+
+ # The CEDATA
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+
+ # end CEDATA
+
+ plot.it.to.image(WTParray, ans, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ framePlot <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(framePlot, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(framePlot, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ ### Image size settings ###
+ numericSpinBox <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Altura da imagem")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", g.imgHeight,sep = ""))
+
+ numericSpinBox2 <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Largura da imagem")
+ tkgrid(labeldigits, numericSpinBox2, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox2, "setvalue", paste("@", g.imgWidth,sep = ""))
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ img.height <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(img.height) )&&(!is.na(img.height))) g.imgHeight <- img.height
+
+ img.width <- as.numeric(tclvalue(tcl(numericSpinBox2,"getvalue")))
+ if ((is.numeric(img.width) )&&(!is.na(img.width))) g.imgWidth <- img.width
+
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(wtp, cedata, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(wtp, cedata, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(plotINBtableWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(wtp, cedata, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotINBtableWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotINBtableWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(framePlot)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ Build.INB <- function(wtp, cedata, to.export = FALSE) {
+ inb <- cedata$Incr.Eff[1] * wtp - cedata$Incr.Cost[1]
+ for (i in 2:dim(cedata)[1]) {
+ balde.inb <- cedata$Incr.Eff[i] * wtp - cedata$Incr.Cost[i]
+ inb <- rbind(inb, balde.inb)
+ }
+
+ inb <- t(inb)
+ inb <- cbind(wtp, inb)
+ if (to.export) {
+ inb <- as.data.frame(inb)
+# print(c("WTP", as.character(cedata$Strategy)))
+ names(inb) <- c("WTP", as.character(cedata$Strategy))
+ } else {
+ colnames(inb) <- c("WTP", cedata$Strategy)
+ }
+# print(inb)
+
+ }
+
+ OnExportText <- function(Original.Dada) {
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(filetypeWindow)
+ else {
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(Original.Dada, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(Original.Dada, file = fileName, sep = "\t")
+ }
+ }
+ tkfocus(plotINBtableWindow)
+ }
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(plotINBtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+
+ OnOKINB <- function() {
+
+ LIVal <- as.numeric(tclvalue(LIvar))
+# print(LIVal)
+ LSVal <- as.numeric(tclvalue(LSvar))
+# print(LSVal)
+ NPVal <- as.numeric(tclvalue(NPvar))
+# print(NPVal)
+
+ do.it <- TRUE
+ if ( !(is.numeric(LIVal)) || (is.na(LIVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite inferior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(LSVal)) || (is.na(LSVal)) ) {
+ do.it <- FALSE
+ msg <- paste("O valor fornecido para o limite superior não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !do.it && ( LIVal > LSVal )) {
+ do.it <- FALSE
+ msg <- paste("O limite inferior deve ser menor que o limite superior.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+ if ( !(is.numeric(NPVal)) || (is.na(NPVal)) || (NPVal < 2) ) {
+ do.it <- FALSE
+ NPVal <- as.integer(NPVal)
+ msg <- paste("O valor fornecido para o número de intervalos não é válido.")
+ tkmessageBox(message=msg)
+ tkfocus(plotINBtableWindow)
+ }
+
+ if (do.it) {
+ file.remove(.Filename)
+ WTParray <- seq(LIVal, LSVal, round( (LSVal - LIVal ) / NPVal))
+
+ respostaListbox <- Data.CEA$Node.N[as.numeric(tkcurselection(tl))+1]
+
+ Data.alternative <- Data.CEA[Data.CEA$Node.N != respostaListbox,]
+ Data.standart <- Data.CEA[Data.CEA$Node.N == respostaListbox, ]
+
+ ans <- data.frame( Strategy = Data.standart$Node.name,
+ Cost = Data.standart$Mean.Cost,
+ Incr.Cost = 0,
+ Effectiveness = Data.standart$Mean.Effectiveness,
+ Incr.Eff = 0,
+ CE.ratio = Data.standart$Mean.Cost / Data.standart$Mean.Effectiveness,
+ ICER = NA
+ )
+
+ for (i in 1:dim(Data.alternative)[1]) {
+ ans.line <- data.frame( Strategy = Data.alternative$Node.name[i],
+ Cost = Data.alternative$Mean.Cost[i],
+ Incr.Cost = Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost,
+ Effectiveness = Data.alternative$Mean.Effectiveness[i],
+ Incr.Eff = Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness,
+ CE.ratio = Data.alternative$Mean.Cost[i] / Data.alternative$Mean.Effectiveness[i],
+ ICER = ((Data.alternative$Mean.Cost[i] - Data.standart$Mean.Cost) /
+ (Data.alternative$Mean.Effectiveness[i] - Data.standart$Mean.Effectiveness))
+ )
+ ans <- abind(ans, ans.line, along = 1)
+
+ }
+ ans <- as.data.frame(ans)
+# print(ans)
+
+ ans$Incr.Cost <- as.numeric(as.character(ans$Incr.Cost))
+ ans$Incr.Eff <- as.numeric(as.character(ans$Incr.Eff))
+
+# INB <- ans$Incr.Eff * WTParray - Incr.Cost
+
+ plot.it.to.image(WTParray, ans, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+ }
+
+ }
+
+ OnCancel <- function() {
+ tkdestroy(plotINBtableWindow)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ tkgrid(frameButton, sticky = "swe")
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.WTP.but <- tkbutton(frameProp,text="OK", width=.Width.but, height=.Height.but, command=OnOKINB)
+ tkgrid(OK.WTP.but, sticky = "s", padx = 5, pady = 5, columnspan = 2)
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnCancel)
+ ExportText.but <- tkbutton(frameButton,text="Relatório", width=.Width.but, height=.Height.but, command = function() OnExportText(Build.INB(WTParray, ans, to.export = TRUE)) )
+ Export.but <- tkbutton(frameButton,text="Exportar", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, ExportText.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(plotINBtableWindow, "<Return>",OnOKINB)
+ tkbind(plotINBtableWindow, "<Escape>",OnCancel)
+
+# posiciona.janela.no.mouse(plotINBtableWindow, 300, 180)
+
+ tkfocus(plotINBtableWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/load.file.arv.Rd
===================================================================
--- pkg/man/load.file.arv.Rd (rev 0)
+++ pkg/man/load.file.arv.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,66 @@
+\name{load.file.arv}
+\alias{load.file.arv}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+load.file.arv(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ if (.workstatus != "saved") {
+ ans <- tkmessageBox(message="Deseja salvar a árvore atual?",icon="question",type="yesnocancel",default="yes")
+ ans <- tclvalue(ans)
+ if (ans == "yes") {
+ save.file.arv()
+ }
+ }
+ fileName <- tclvalue(tkgetOpenFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ clearTreeTkArvore(TheTree)
+ load(fileName, envir = .EnvironmentArvoRe)
+ load(fileName)
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ }
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ titletext <- paste("ÁrvoRe - Janela Principal - [", fileName, "]", sep = "")
+ tkwm.title(tt, titletext)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/markov.coort.table.Rd
===================================================================
--- pkg/man/markov.coort.table.Rd (rev 0)
+++ pkg/man/markov.coort.table.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,286 @@
+\name{markov.coort.table}
+\alias{markov.coort.table}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+markov.coort.table(TheTree, markov.propertiesMAT, markov.termination, initial.coort = 10000, seed = FALSE, absorventstatedeath = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{markov.propertiesMAT}{ ~~Describe \code{markov.propertiesMAT} here~~ }
+ \item{markov.termination}{ ~~Describe \code{markov.termination} here~~ }
+ \item{initial.coort}{ ~~Describe \code{initial.coort} here~~ }
+ \item{seed}{ ~~Describe \code{seed} here~~ }
+ \item{absorventstatedeath}{ ~~Describe \code{absorventstatedeath} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, markov.propertiesMAT, markov.termination, initial.coort = 10000, seed = FALSE,
+ absorventstatedeath = 1) {
+
+ # ajusta a semente escolhida pelo usuário
+ if (seed != FALSE) {
+ set.seed(seed)
+ }
+
+ # Convert the tree to matrix format
+ MatrixTheTree <- convert2matrix(TheTree)
+ x <- MatrixTheTree$x # Structure matrix
+ y <- MatrixTheTree$y # Node name matrix
+ typeMAT <- MatrixTheTree$typeMAT # Node type matrix
+ utilityMAT <- MatrixTheTree$utilityMAT # Node Cost matrix
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT # Node effectiveness matrix
+ probMAT <- MatrixTheTree$probMAT # Node probability matrix
+ destinyMAT <- MatrixTheTree$destinyMAT # Terminal node destiny matrix
+
+ num.col.x <- dim(x)[2]
+ num.lin.x <- dim(x)[1]
+
+ SummaryTreeTable <- subset(TheTree, Level == 2)
+ col.pos <- as.numeric(SummaryTreeTable$Level)
+ MARKOV.states <- as.numeric(SummaryTreeTable$Node.N) # MARKOV.states
+# print(MARKOV.states)
+ MARKOV.states.init.prob <- as.numeric(SummaryTreeTable$Prob) # MARKOV.states
+# print(MARKOV.states.init.prob)
+ MARKOV.states.init.cost.rwd <- as.numeric(markov.propertiesMAT$Initial.cost) # MARKOV.states
+ MARKOV.states.incr.cost.rwd <- as.numeric(markov.propertiesMAT$Incremental.cost) # MARKOV.states
+ MARKOV.states.final.cost.rwd <- as.numeric(markov.propertiesMAT$Final.cost) # MARKOV.states
+ MARKOV.states.init.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Initial.effectiveness) # MARKOV.states
+ MARKOV.states.incr.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Incremental.effectiveness) # MARKOV.states
+ MARKOV.states.final.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Final.effectiveness) # MARKOV.states
+
+ MARKOV.states.names <- SummaryTreeTable$Node.name
+# print(MARKOV.states.names)
+
+ # listas para comportar matrizes associadas a cada Markov state
+ MARKOV.states.arvores <- list()
+ MARKOV.states.rotulos <- list()
+ MARKOV.states.destino <- list()
+ MARKOV.states.probs <- list()
+ MARKOV.states.utilities <- list()
+ MARKOV.states.costs <- list()
+ MARKOV.states.effectiveness <- list()
+
+ # fragmenta a matriz da árvore em sub-árvores associadas a cada Markov state
+ for (i in 1:length(MARKOV.states.names)) {
+ MARKOV.state <- MARKOV.states[i]
+ selected.lines <- which(x[,col.pos[i]] == MARKOV.state)
+
+ sub.x <- x[selected.lines, col.pos[i]:num.col.x]
+ sub.y <- y[selected.lines, col.pos[i]:num.col.x]
+ sub.probMAT <- probMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.utilityMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.effectivenessMAT <- effectivenessMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.typeMAT <- utilityMAT[selected.lines, col.pos[i]:num.col.x]
+ sub.destiny <- destinyMAT[selected.lines]
+
+ # se a fragmentação resulta em matriz linha, então é preciso definir que isso é
+ # uma matriz... senão vira vetor e não funciona.
+ if(length(selected.lines) == 1) {
+ sub.x <- sub.x[!is.na(sub.x)]
+ n.mat <- length(sub.x) + 1
+ sub.x <- matrix(c(1, sub.x) , 1, n.mat)
+ sub.y <- matrix(sub.y[1], 1, n.mat)
+ sub.probMAT <- matrix(1.0, 1, n.mat)
+ sub.utilityMAT <- matrix(c(0,sub.utilityMAT), 1, n.mat)
+ sub.effectivenessMAT <- matrix(c(0,sub.effectivenessMAT), 1, n.mat)
+ sub.typeMAT <- matrix(c("D",sub.typeMAT), 1, n.mat)
+ } else {
+ sub.probMAT[,1] <- 1.0 # Agora o nodo raiz recebe prob = 1.
+ }
+
+ # ajusta custo e efetividade: serão acumulados através dos nodos.
+ sub.utilityMAT <- apply(sub.utilityMAT, 1, sum)
+ sub.effectivenessMAT <- apply(sub.effectivenessMAT, 1, sum)
+
+ # abaixo se manda cada matriz de sub-árvore para suas listas.
+ MARKOV.states.arvores[[i]] <- sub.x
+ MARKOV.states.rotulos[[i]] <- sub.y
+ MARKOV.states.destino[[i]] <- sub.destiny
+ MARKOV.states.probs[[i]] <- sub.probMAT
+ MARKOV.states.costs[[i]] <- sub.utilityMAT
+ MARKOV.states.effectiveness[[i]] <- sub.effectivenessMAT
+ MARKOV.states.utilities[[i]] <- sub.utilityMAT / sub.effectivenessMAT
+ }
+
+ # ajusta nomes nas listas.
+ names(MARKOV.states.arvores) <- c(as.array(as.character(MARKOV.states)))
+ names(MARKOV.states.rotulos) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.destino) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.probs) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.costs) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.effectiveness) <- names(MARKOV.states.arvores)
+ names(MARKOV.states.utilities) <- names(MARKOV.states.arvores)
+
+# print(" MOSTRANDO... MARKOV.states.arvores")
+# print(MARKOV.states.arvores)
+# assign("MARKOV.states.arvores", MARKOV.states.arvores, globalenv())
+# print(" MOSTRANDO... MARKOV.states.rotulos")
+# print(MARKOV.states.rotulos)
+# assign("MARKOV.states.rotulos", MARKOV.states.rotulos, globalenv())
+# print(" MOSTRANDO... MARKOV.states.destino")
+# print(MARKOV.states.destino)
+# assign("MARKOV.states.destino", MARKOV.states.destino, globalenv())
+# print(" MOSTRANDO... MARKOV.states.probs")
+# print(MARKOV.states.probs)
+# assign("MARKOV.states.probs", MARKOV.states.probs, globalenv())
+# print(" MOSTRANDO... MARKOV.states.utilities")
+# print(MARKOV.states.utilities)
+# assign("MARKOV.states.utilities", MARKOV.states.utilities, globalenv())
+# print(" MOSTRANDO... MARKOV.states.costs")
+# print(MARKOV.states.costs)
+# assign("MARKOV.states.costs", MARKOV.states.costs, globalenv())
+# print(" MOSTRANDO... MARKOV.states.effectiveness")
+# print(MARKOV.states.effectiveness)
+# assign("MARKOV.states.effectiveness", MARKOV.states.effectiveness, globalenv())
+
+ # Busca por estados absorventes
+ if (absorventstatedeath == 1) {
+ nodos.test.absorvent <- names(MARKOV.states.destino)
+ absorventstate <- array(,0)
+
+ for (i in nodos.test.absorvent) {
+ destinyofthisstate <- MARKOV.states.destino[[i]]
+# print(destinyofthisstate)
+ checkdestiny <- ( destinyofthisstate == i )
+# print(checkdestiny)
+ if ( sum(checkdestiny) == length(destinyofthisstate) ) {
+# cat("Ele é absorvente '", i, "' chamado '", MARKOV.states.rotulos[[i]][1,1],"'\n")
+ absorventstate <- c(absorventstate, i)
+ }
+ }
+ }
+
+ # cria a tabela que comportará os individuos
+ num.markov.states <- length(MARKOV.states)
+ Coorte.Ind <- matrix(MARKOV.states[num.markov.states],1,initial.coort) # Matriz com cada individuo
+ Coorte.Cost <- matrix(0,1,initial.coort) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(0,1,initial.coort) # Matriz com a efetividade de cada individuo
+
+ # sorteia a distribuição inicial
+ init.distr.Prob <- cumsum(MARKOV.states.init.prob)
+ sorteados <- runif(initial.coort,0,1)
+ if (num.markov.states > 1) {
+ for (i in (num.markov.states-1):1) {
+ positions <- which( sorteados <= init.distr.Prob[i] )
+ Coorte.Ind[1,positions] <- MARKOV.states[i]
+ Coorte.Cost[1,positions] <- MARKOV.states.init.cost.rwd[i]
+ Coorte.Effec[1,positions] <- MARKOV.states.init.effectiveness.rwd[i]
+ }
+ }
+
+ # control variables
+ .stop.sim <- TRUE
+ .stage <- 0
+ .stage.reward <- 0
+ .stage.cost <- 0
+ .stage.eff <- 0
+ .total.reward <- 0 # ajusta a soma do ciclo zero para zero.
+ .total.cost <- 0
+ .total.eff <- 0
+
+ while( ! eval( parse(text = markov.termination) ) ) {
+ .stage <- .stage + 1
+ Coorte.Ind.LINE <- matrix(MARKOV.states[num.markov.states],1,initial.coort)
+ Coorte.Cost.LINE <- matrix(0,1,initial.coort)
+ Coorte.Effec.LINE <- matrix(0,1,initial.coort)
+
+ for (i in 1:num.markov.states ) {
+ positions <- which(Coorte.Ind[.stage,] == MARKOV.states[i])
+ indvs <- length(positions)
+ if ( indvs != 0 ) {
+ arvore <- MARKOV.states.arvores[[as.character(MARKOV.states[i])]]
+ rotulos <- MARKOV.states.rotulos[[as.character(MARKOV.states[i])]]
+ destinos <- MARKOV.states.destino[[as.character(MARKOV.states[i])]]
+ probabilidades <- MARKOV.states.probs[[as.character(MARKOV.states[i])]]
+ custos <- MARKOV.states.costs[[as.character(MARKOV.states[i])]]
+ efetividades <- MARKOV.states.effectiveness[[as.character(MARKOV.states[i])]]
+ utilidades <- MARKOV.states.utilities[[as.character(MARKOV.states[i])]]
+ sorteado <- runif(indvs,0,1)
+ linprobs <- cumsum(apply(probabilidades, 1, prod)) # observa a probabilidade de cada ramo acontecer numa runif
+ valn <- length(linprobs)
+ linprobs.Matrix <- matrix(linprobs, indvs, valn, byrow = TRUE) # podemos ter problema de memória aqui!!!
+ resultado <- valn - apply(sorteado <= linprobs.Matrix, 1, sum) + 1
+ ans.dest <- destinos[resultado] # quantos vão para cada categoria
+ ans.cost <- custos[resultado]
+ ans.effectiveness <- efetividades[resultado]
+ }
+ Coorte.Ind.LINE[1,positions] <- ans.dest
+ Coorte.Cost.LINE[1,positions] <- ans.cost
+ Coorte.Effec.LINE[1,positions] <- ans.effectiveness
+ }
+ Coorte.Ind <- rbind(Coorte.Ind, Coorte.Ind.LINE)
+ Coorte.Cost <- rbind(Coorte.Cost, Coorte.Cost.LINE)
+ Coorte.Effec <- rbind(Coorte.Effec, Coorte.Effec.LINE)
+ }
+
+ # Definições para a soma de valores no final da simulação (the final reward)
+ for (i in num.markov.states:1) {
+ positions <- which( Coorte.Ind[.stage + 1,] <= MARKOV.states[i] )
+ Coorte.Cost[.stage + 1,positions] <- MARKOV.states.final.cost.rwd[i]
+ Coorte.Effec[.stage + 1,positions] <- MARKOV.states.final.effectiveness.rwd[i]
+ }
+
+# print(" MOSTRANDO... Coorte.Ind")
+# print(Coorte.Ind)
+# print(" MOSTRANDO... Coorte.Cost")
+# print(Coorte.Cost)
+# print(" MOSTRANDO... Coorte.Effec")
+# print(Coorte.Effec)
+
+ # Aplica NA para individuos dos estados absorventes considerados morte
+ if (absorventstatedeath == 1) {
+ SurvivalCurve <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
+# Coorte.Ind <- replace(Coorte.Ind, which( Coorte.Ind == absorventstate), NA)
+# Coorte.Cost2 <- replace(Coorte.Ind, which( SurvivalCurve == NA), NA)
+# Coorte.Effec2 <- replace(Coorte.Ind, which( SurvivalCurve == NA), NA)
+ SurvivalCurve <- apply(!is.na(SurvivalCurve), 1, sum)
+ SurvivalCurve <- as.array(SurvivalCurve)
+ names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
+# print(SurvivalCurve)
+ } else {
+ SurvivalCurve <- rep( dim(Coorte.Ind)[2], dim(Coorte.Ind)[1])
+ names(SurvivalCurve) <- paste("Cycle ", 0:(length(SurvivalCurve)-1), sep = "")
+# print(SurvivalCurve)
+ }
+
+# print(" MOSTRANDO... Coorte.Ind")
+# print(Coorte.Ind)
+# print(" MOSTRANDO... Coorte.Cost")
+# print(Coorte.Cost)
+# print(" MOSTRANDO... Coorte.Effec")
+# print(Coorte.Effec)
+
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec, Survival = SurvivalCurve)
+ return(ans) # And return the result
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/markov.nodes.properties.Rd
===================================================================
--- pkg/man/markov.nodes.properties.Rd (rev 0)
+++ pkg/man/markov.nodes.properties.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,183 @@
+\name{markov.nodes.properties}
+\alias{markov.nodes.properties}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+markov.nodes.properties(TheTree, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .EnvironmentArvoRe) {
+ exist.var <- exists("markov.propertiesMAT", envir = .EnvironmentArvoRe)
+ if (!exist.var) {
+ markov.propertiesMAT <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+ } else {
+ markov.propertiesMAT <- get("markov.propertiesMAT", .EnvironmentArvoRe)
+ }
+
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ position.father <- intersect(which((TheTree$Level == (column-1))),which(TheTree$Node.N == TheTree$Father[position]))
+
+ if ( (TheTree$Type[position.father] == "M") &&
+ ((TheTree$Type[position] == "T") || (TheTree$Type[position] == "C")) ) {
+ markovnodeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(markovnodeWindow,title)
+
+ position.markov <- intersect(which((markov.propertiesMAT$Level == column)),
+ which(markov.propertiesMAT$Node.N == node.number))
+
+ if ( length(position.markov) != 0) {
+ Initial.costvar <- tclVar(markov.propertiesMAT$Initial.cost[position.markov])
+ Incremental.costvar <- tclVar(markov.propertiesMAT$Incremental.cost[position.markov])
+ Final.costvar <- tclVar(markov.propertiesMAT$Final.cost[position.markov])
+ Initial.effectivenessvar <- tclVar(markov.propertiesMAT$Initial.effectiveness[position.markov])
+ Incremental.effectivenessvar <- tclVar(markov.propertiesMAT$Incremental.effectiveness[position.markov])
+ Final.effectivenessvar <- tclVar(markov.propertiesMAT$Final.effectiveness[position.markov])
+ } else {
+ Initial.costvar <- tclVar(0)
+ Incremental.costvar <- tclVar(0)
+ Final.costvar <- tclVar(0)
+ Initial.effectivenessvar <- tclVar(0)
+ Incremental.effectivenessvar <- tclVar(0)
+ Final.effectivenessvar <- tclVar(0)
+ }
+
+ entry.Value <- tkentry(markovnodeWindow,width="20",textvariable=Initial.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Inicial (ciclo zero)"), sticky = "nw")
+ tkgrid(entry.Value, sticky = "n")
+
+ entry.Value2 <- tkentry(markovnodeWindow,width="20",textvariable=Incremental.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Adicional (por ciclo)"), sticky = "nw")
+ tkgrid(entry.Value2, sticky = "n")
+
+ entry.Value3 <- tkentry(markovnodeWindow,width="20",textvariable=Final.costvar)
+ tkgrid(tklabel(markovnodeWindow,text="Custo Final (após o final)"), sticky = "nw")
+ tkgrid(entry.Value3, sticky = "n")
+
+ entry.Value4 <- tkentry(markovnodeWindow,width="20",textvariable=Initial.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Inicial (ciclo zero)"), sticky = "nw")
+ tkgrid(entry.Value4, sticky = "n")
+
+ entry.Value5 <- tkentry(markovnodeWindow,width="20",textvariable=Incremental.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Adicional (por ciclo)"), sticky = "nw")
+ tkgrid(entry.Value5, sticky = "n")
+
+ entry.Value6 <- tkentry(markovnodeWindow,width="20",textvariable=Final.effectivenessvar)
+ tkgrid(tklabel(markovnodeWindow,text="Efetividade Final (após o final)"), sticky = "nw")
+ tkgrid(entry.Value6, sticky = "n")
+
+ OnOK <- function()
+ {
+ Initial.costVal <- as.character(tclvalue(Initial.costvar))
+ Incremental.costVal <- as.character(tclvalue(Incremental.costvar))
+ Final.costVal <- as.character(tclvalue(Final.costvar))
+ Initial.effectivenessVal <- as.character(tclvalue(Initial.effectivenessvar))
+ Incremental.effectivenessVal <- as.character(tclvalue(Incremental.effectivenessvar))
+ Final.effectivenessVal <- as.character(tclvalue(Final.effectivenessvar))
+
+ if ( (!is.na(Initial.costVal)) && (nchar(Initial.costVal) > 0) &&
+ (!is.na(Incremental.costVal)) && (nchar(Incremental.costVal) > 0) &&
+ (!is.na(Final.costVal)) && (nchar(Final.costVal) > 0) &&
+ (!is.na(Initial.effectivenessVal)) && (nchar(Initial.effectivenessVal) > 0) &&
+ (!is.na(Incremental.effectivenessVal)) && (nchar(Incremental.effectivenessVal) > 0) &&
+ (!is.na(Final.effectivenessVal)) && (nchar(Final.effectivenessVal) > 0)
+ ) {
+ tkdestroy(markovnodeWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ set.markov.nodes.properties(TheTree, markov.propertiesMAT, column = column, node.number = node.number,
+ Initial.rwd.cost = Initial.costVal,
+ Incremental.rwd.cost = Incremental.costVal,
+ Final.rwd.cost = Final.costVal,
+ Initial.rwd.effectiveness = Initial.effectivenessVal,
+ Incremental.rwd.effectiveness = Incremental.effectivenessVal,
+ Final.rwd.effectiveness = Final.effectivenessVal)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Os valores definidos não são válidos.")
+ tkmessageBox(message = msg, icon="error", title = "ÁrvoRe - AVISO")
+ tkfocus(markovnodeWindow)
+ }
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but,text="OK",command=OnOK)
+ tkbind(markovnodeWindow, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(markovnodeWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancel", command=OnCancel)
+
+ tkbind(markovnodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkfocus(markovnodeWindow)
+# posiciona.janela.no.mouse(markovnodeWindow, 230, 280)
+ } else {
+ msg <- paste("O nodo selecionado não é ramificação de um nodo Markov \n ou é de tipo inválido.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/naoimplementado.Rd
===================================================================
--- pkg/man/naoimplementado.Rd (rev 0)
+++ pkg/man/naoimplementado.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,45 @@
+\name{naoimplementado}
+\alias{naoimplementado}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+naoimplementado()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ require(tcltk)
+ Mensagem.txt <- "Esta funcionalidade não foi implementada ainda. Desculpe-nos."
+ tkmessageBox(message=Mensagem.txt, icon="warning", type="ok", title = "Markov - Custo Efetividade")
+ tkfocus(tt)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/new.file.bot.Rd
===================================================================
--- pkg/man/new.file.bot.Rd (rev 0)
+++ pkg/man/new.file.bot.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,62 @@
+\name{new.file.bot}
+\alias{new.file.bot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+new.file.bot(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ ans <- tkmessageBox(message="Deseja salvar a árvore atual?",icon="question",type="yesnocancel",default="yes")
+ ans <- tclvalue(ans)
+ if (ans != "yes") {
+ if (ans == "no") {
+ clearTreeTkArvore(TheTree)
+ new.tree()
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ } else {
+ tkfocus(tt)
+ }
+ } else {
+ save.file.arv()
+ clearTreeTkArvore(TheTree)
+ new.tree()
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/new.tree.Rd
===================================================================
--- pkg/man/new.tree.Rd (rev 0)
+++ pkg/man/new.tree.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,76 @@
+\name{new.tree}
+\alias{new.tree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+new.tree()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ Payoffs <- matrix(0,1,2)
+
+ colnames(Payoffs) <- paste("Payoff",1:length(Payoffs),sep="")
+
+ TheTree <- data.frame( Level = 1, Node.N = 1, Node.name = "Decision",
+ Father = 0, Father.Name = "root",
+ Prob = 1, Type = "D", Note = " ", Destiny = " ",
+ Payoffs)
+
+ TheTree$Level <- as.numeric(TheTree$Level)
+ TheTree$Node.N <- as.numeric(TheTree$Node.N)
+ TheTree$Node.name <- as.character(TheTree$Node.name)
+ TheTree$Father <- as.numeric(TheTree$Father)
+ TheTree$Father.Name <- as.character(TheTree$Father.Name)
+ TheTree$Prob <- as.numeric(TheTree$Prob)
+ TheTree$Type <- as.character(TheTree$Type)
+ TheTree$Note <- as.character(TheTree$Note)
+ TheTree$Destiny <- as.character(TheTree$Destiny)
+ TheTree$Payoff1 <- as.numeric(TheTree$Payoff1)
+ TheTree$Payoff2 <- as.numeric(TheTree$Payoff2)
+
+ markov.propertiesMAT <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+
+ assign("TheTree", TheTree, .EnvironmentArvoRe)
+ assign("markov.propertiesMAT", markov.propertiesMAT, .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/new.variable.list.Rd
===================================================================
--- pkg/man/new.variable.list.Rd (rev 0)
+++ pkg/man/new.variable.list.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,51 @@
+\name{new.variable.list}
+\alias{new.variable.list}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+new.variable.list()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ Variable <- array(" ",0)
+ StdValue <- array(0,0)
+ MinValue <- array(0,0)
+ MaxValue <- array(0,0)
+ Notes <- array(" ",0)
+
+ ans <- data.frame("Name" = Variable, "Fix.Value" = StdValue, "Min.Value" = MinValue,
+ "Max.Value" = MaxValue, "Notes" = Notes)
+ ans <- as.data.frame(ans)
+ assign("variableMAT", ans, .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/nodenamewindows.Rd
===================================================================
--- pkg/man/nodenamewindows.Rd (rev 0)
+++ pkg/man/nodenamewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,91 @@
+\name{nodenamewindows}
+\alias{nodenamewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+nodenamewindows()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ nodenameWindow <- tktoplevel()
+ title <- "ÁrvoRe - Nome Nodo"
+ tkwm.title(nodenameWindow,title)
+
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ Namevar <- tclVar(TheTree$Node.name[position])
+
+ entry.Value <- tkentry(nodenameWindow,width="20",textvariable=Namevar)
+ tkgrid(tklabel(nodenameWindow,text="Nome do Nodo"), sticky = "n")
+ tkgrid(entry.Value, sticky = "n")
+ OnOK <- function()
+ {
+ NameVal <- as.character(tclvalue(Namevar))
+ if ( (is.character(NameVal)) && (!is.na(NameVal)) && (nchar(NameVal) > 0) ) {
+ tkdestroy(nodenameWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setnodename(TheTree, nodeSec[2], nodeSec[3], NameVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um nome de nodo válido '",NameVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(nodenameWindow)
+ }
+ }
+ OK.but <-tkbutton(nodenameWindow,text=" OK ",command=OnOK)
+ tkbind(entry.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(nodenameWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(nodenameWindow, text=" Cancel ", command=OnCancel)
+ tkbind(nodenameWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkfocus(nodenameWindow)
+ posiciona.janela.no.mouse(nodenameWindow, 200, 100)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/nodoselecionado.Rd
===================================================================
--- pkg/man/nodoselecionado.Rd (rev 0)
+++ pkg/man/nodoselecionado.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,56 @@
+\name{nodoselecionado}
+\alias{nodoselecionado}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+nodoselecionado()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ ans <- tclvalue(tcl(treeWidget,"selection","get"))
+ if ( ans == "") {
+ return(" ")
+ } else {
+ pos <- 1
+ while (pos <= nchar(ans)) {
+ if ( substr(ans, pos, pos) == "." ) {
+ ans.node <- substr(ans,1,pos-1)
+ ans.col <- substr(ans,pos+1,nchar(ans))
+ pos <- nchar(ans) + 1
+ }
+ pos <- pos + 1
+ }
+ return(c(ans,ans.node,ans.col))
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/notesnodewindows.Rd
===================================================================
--- pkg/man/notesnodewindows.Rd (rev 0)
+++ pkg/man/notesnodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,90 @@
+\name{notesnodewindows}
+\alias{notesnodewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+notesnodewindows(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+
+ notesWindow <- tktoplevel()
+ title <- "ÁrvoRe - Comentários do Nodo"
+ tkwm.title(notesWindow,title)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ Notesvar <- tclVar(TheTree$Note[position])
+ entry.Value <- tkentry(notesWindow, width="20", textvariable=Notesvar)
+ tkgrid(tklabel(notesWindow,text="Nota"))
+ tkgrid(entry.Value)
+
+ OnOK <- function()
+ {
+ NotesVal <- as.character(tclvalue(Notesvar))
+ tkdestroy(notesWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setnotesnode(TheTree, column = column, node.number = node.number, nodo.note = NotesVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ }
+ OK.but <-tkbutton(notesWindow, text=" OK ", command=OnOK)
+ tkbind(entry.Value, "<Return>", OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(notesWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(notesWindow, text=" Cancel ", command=OnCancel)
+ tkbind(notesWindow, "<Escape>", OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(notesWindow, 200, 100)
+ tkfocus(notesWindow)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/planoacewindow.Rd
===================================================================
--- pkg/man/planoacewindow.Rd (rev 0)
+++ pkg/man/planoacewindow.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,362 @@
+\name{planoacewindow}
+\alias{planoacewindow}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+planoacewindow(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ require(abind)
+ require(gplots)
+
+ plotCEtableWindow <- tktoplevel()
+ title <- "ÁrvoRe - Análise de Custo-Efetividade"
+ tkwm.title(plotCEtableWindow,title)
+
+ # What plot?
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(plotCEtableWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(plotCEtableWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvoreCE.png", sep="")
+
+ # The data to plot
+ Data.CEA <- cost.effectiveness.table(TheTree)
+ AllTreatCost <- Data.CEA$Mean.Cost
+# print(AllTreatCost)
+ AllTreatEffectiveness <- Data.CEA$Mean.Effectiveness
+# print(AllTreatEffectiveness)
+ AllTreatCE <- Data.CEA$Mean.Cost / Data.CEA$Mean.Effectiveness
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(Data.CEA$Node.name)
+ # The treatments names
+ treatments.label.plot <- Data.CEA$Node.name
+
+ # Default img type
+ img.type <- "png"
+ img.quality <- 90
+
+ plot.it.to.image <- function(AllTreatCost, AllTreatEffectiveness, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 400, img.height = 400, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness, AllTreatCost,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ for (i in length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness, AllTreatCost,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ for (i in length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness, AllTreatCost,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ for (i in length(AllTreatEffectiveness)) {
+ lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i])
+ }
+ dev.off()
+ }
+ }
+ }
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ ### Image size settings ###
+ numericSpinBox <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Altura da imagem")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", g.imgHeight,sep = ""))
+
+ numericSpinBox2 <- tkwidget(frameUpperRigth, "SpinBox", editable=TRUE, range = c(100,10000,1), width = 5)
+ labeldigits <- tklabel(frameUpperRigth,text="Largura da imagem")
+ tkgrid(labeldigits, numericSpinBox2, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox2, "setvalue", paste("@", g.imgWidth,sep = ""))
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ img.height <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(img.height) )&&(!is.na(img.height))) g.imgHeight <- img.height
+
+ img.width <- as.numeric(tclvalue(tcl(numericSpinBox2,"getvalue")))
+ if ((is.numeric(img.width) )&&(!is.na(img.width))) g.imgWidth <- img.width
+
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, img.type = ImgFormatselected,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotCEtableWindow)
+ tkfocus(plotCEtableWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(plotCEtableWindow)
+ tkfocus(plotCEtableWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(plotCEtableWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(plotCEtableWindow)
+ file.remove(.Filename)
+ # tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <- tkbutton(frameButton,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel)
+ Export.but <- tkbutton(frameButton,text="Exportar", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Cancel.but, Export.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(plotCEtableWindow, "<Return>",OnOK)
+ tkbind(plotCEtableWindow, "<Escape>",OnOK)
+
+# posiciona.janela.no.mouse(plotCEtableWindow, 300, 180)
+
+ tkfocus(plotCEtableWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/plot.tree.Rd
===================================================================
--- pkg/man/plot.tree.Rd (rev 0)
+++ pkg/man/plot.tree.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,287 @@
+\name{plot.tree}
+\alias{plot.tree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+plot.tree(TheTree, line.type = "squared", show.probability = TRUE, show.payoffs = TRUE, show.notes = FALSE, node.name.font.size = 12, payoffs.font.size = 0, notes.font.size = 0)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{line.type}{ ~~Describe \code{line.type} here~~ }
+ \item{show.probability}{ ~~Describe \code{show.probability} here~~ }
+ \item{show.payoffs}{ ~~Describe \code{show.payoffs} here~~ }
+ \item{show.notes}{ ~~Describe \code{show.notes} here~~ }
+ \item{node.name.font.size}{ ~~Describe \code{node.name.font.size} here~~ }
+ \item{payoffs.font.size}{ ~~Describe \code{payoffs.font.size} here~~ }
+ \item{notes.font.size}{ ~~Describe \code{notes.font.size} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, line.type = "squared", show.probability = TRUE,
+ show.payoffs = TRUE, show.notes = FALSE, node.name.font.size = 12,
+ payoffs.font.size = 0, notes.font.size = 0) {
+
+ require(grid)
+
+ MatrixTheTree <- convert2matrix(TheTree)
+ x <- MatrixTheTree$x
+ rotulos <- MatrixTheTree$y
+ typeMAT <- MatrixTheTree$typeMAT
+ utilityMAT <- MatrixTheTree$utilityMAT
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT
+ probMAT <- MatrixTheTree$probMAT
+ notesMAT <- MatrixTheTree$notesMAT
+
+ nc <- dim(x)[2]
+ nl <- dim(x)[1]
+
+ # Objetos
+ colorMAT <- matrix(0,nl,nc)
+ ylabelspace <- .021
+ colortext <- "black"
+ if (payoffs.font.size == 0) payoffs.font.size <- round(node.name.font.size/2,0)
+ if (notes.font.size == 0) notes.font.size <- round(node.name.font.size/2,0)
+
+ grid.newpage()
+
+ sizelabels <- matrix(0,nl,nc)
+ for (i in 1:nl) {
+ for (j in 1:nc) {
+ sizelabels[i,j] <- nchar(rotulos[i,j])
+ }
+ }
+
+ propcolx <- apply(sizelabels, 2, max)
+ propcolx <- cumsum(propcolx/2)
+
+ xpos <- NA*x
+ ypos <- NA*x
+ deltax <- 1 / ( max(propcolx) + 6 )
+
+ for( i in 1:nc) {
+ nniveis <- nl
+ niveis <- levels(as.factor(x[,i]))
+ deltay <- 1 / (nniveis + 1)
+ for (j in niveis) {
+ positions <- which(x[,i] == j)
+ ypos[positions, i] <- (nl - median(positions, na.rm = TRUE)) * deltay + deltay
+ }
+ xpos[,i] <- rep(1, nl) * deltax * propcolx[i]
+ }
+
+ if (nc > 1) {
+ if (line.type == "normal") {
+ for( i in 1:nl) {
+ for( j in 1:(nc-1)) {
+ linx <- c( xpos[i,j] , xpos[i,j+1] )
+ liny <- c( ypos[i,j] , ypos[i,j+1] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ }
+ } else {
+
+ for( i in 1:(nc-1)) { # plota as linhas verticais
+ nodos <- as.numeric(names(table(x[,i])))
+ for (j in nodos) {
+ positions <- which(x[,i] == j)
+ if ( (length(positions) >= 2) && (!is.na(x[positions[1],i+1])) ) {
+ linx <- c( xpos[positions[1],i] + (xpos[positions[1],i+1] - xpos[positions[1],i])/2 , xpos[positions[1],i] + (xpos[positions[1],i+1] - xpos[positions[1],i])/2 )
+ linymax <- max(ypos[positions,i+1], na.rm = TRUE)
+ linymin <- min(ypos[positions,i+1], na.rm = TRUE)
+ liny <- c(linymin,linymax)
+ grid.polyline( linx, liny )
+ }
+ }
+ }
+ for( i in 1:nl) { # plota as linhas horizontais
+ for( j in 1:(nc-1)) {
+ linx <- c( xpos[i,j] , xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2 )
+ liny <- c( ypos[i,j] , ypos[i,j] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ # plota linhas depois do nome para os nodos do último nível em uma dada "linha da matriz estrutura"
+ linx <- c( xpos[i,nc] , xpos[i,nc] + (xpos[i,nc] - xpos[i,nc-1])/2 )
+ liny <- c( ypos[i,nc] , ypos[i,nc] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ for( j in 2:nc) {
+ linx <- c( xpos[i,j-1] + (xpos[i,j] - xpos[i,j-1]) / 2, xpos[i,j] )
+ liny <- c( ypos[i,j] , ypos[i,j] )
+ d <- sum(is.na(c(linx,liny)))
+ if (d == 0) grid.polyline( linx, liny )
+ }
+ }
+ }
+ }
+
+ # computa a matriz de cores
+ for( i in 1:nl) {
+ for (j in 1:nc) {
+ if ( (typeMAT[i,j] == "C")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "green"
+ else if ( (typeMAT[i,j] == "T")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "red"
+ else if ( (typeMAT[i,j] == "M")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "yellow"
+ else if ( (typeMAT[i,j] == "D")&&(!is.na(x[i,j])) ) colorMAT[i,j] <- "blue"
+ else colorMAT[i,j] <- "grey"
+ }
+ }
+
+ # plota grafico para o primeiro nodo
+ grid.text(rotulos[1,1], x = xpos[1,1],
+ y = ypos[1,1] + ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = node.name.font.size, col = colortext))
+
+ if (nc > 1) {
+ if ( line.type == "squared") {
+ grid.circle(x = xpos[1,1] + (xpos[1,2]-xpos[1,1])/2,
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ } else {
+ grid.circle(x = xpos[1,1],
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ }
+ for( i in 1:nl) {
+ for (j in 2:nc) {
+ d <- sum(is.na(c(xpos[i,j],ypos[i,j])))
+ if (d == 0) {
+ grid.text(rotulos[i,j], x = xpos[i,j] ,
+ y = ypos[i,j] + ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = node.name.font.size, col=colortext))
+ minortext <- as.character("")
+ if (show.probability) minortext <- paste("prob. ",probMAT[i,j], sep = "")
+ if (show.payoffs) {
+ minortext <- paste(minortext, "\n cost. ", utilityMAT[i,j], sep = "")
+ if (.modeltypeArvore == "CE") {
+ minortext <- paste(minortext, "\n effect. ", effectivenessMAT[i,j], sep = "")
+ }
+ }
+ grid.text(minortext,
+ x = xpos[i,j],
+ y = ypos[i,j] - 2 * ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = payoffs.font.size, col=colortext))
+ if (show.notes) {
+ nreptext <- sum(c(show.probability, show.payoffs, (.modeltypeArvore == "CE")))
+ minortext2 <- paste(rep("\n",nreptext), notesMAT[i,j], sep = "")
+ grid.text(minortext2,
+ x = xpos[i,j],
+ y = ypos[i,j] - 2 * ylabelspace,
+ just = "centre",
+ rot = 0, gp = gpar(fontsize = notes.font.size, col=colortext))
+ }
+ # Desenhos dos nodos - para o caso "normal" e "squared"
+ if ( line.type == "squared") {
+ if ( j != nc) {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2,
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j] + (xpos[i,j+1] - xpos[i,j])/2
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ } else {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j] + (xpos[i,j] - xpos[i,j-1])/2,
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j] + (xpos[i,j] - xpos[i,j-1])/2
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ }
+ } else {
+ if ( j != nc) {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j],
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j]
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ } else {
+ if (typeMAT[i,j] != "T") {
+ grid.circle(x = xpos[i,j],
+ y = ypos[i,j],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ } else {
+ triangX <- xpos[i,j]
+ grid.polygon(x = c( triangX, triangX + .015, triangX + .015),
+ y = c( ypos[i,j], ypos[i,j] + .015, ypos[i,j] - .015),
+ default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[i,j]),
+ draw=TRUE, vp=NULL)
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ grid.circle(x = xpos[1,1] + (xpos[1,1])/2,
+ y = ypos[1,1],
+ r = .012, default.units="npc", name=NULL,
+ gp=gpar(fill=colorMAT[1,1]),
+ draw=TRUE, vp=NULL)
+ }
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/posiciona.janela.centro.Rd
===================================================================
--- pkg/man/posiciona.janela.centro.Rd (rev 0)
+++ pkg/man/posiciona.janela.centro.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,76 @@
+\name{posiciona.janela.centro}
+\alias{posiciona.janela.centro}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+posiciona.janela.centro(janela.principal, janela.nova)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{janela.principal}{ ~~Describe \code{janela.principal} here~~ }
+ \item{janela.nova}{ ~~Describe \code{janela.nova} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(janela.principal, janela.nova) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.principal) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.principal) ) )
+
+ wm.main.height <- as.integer( tclvalue( tkwinfo("height", janela.principal) ) )
+ wm.main.width <- as.integer( tclvalue( tkwinfo("width", janela.principal) ) )
+
+ wm.child.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ wm.child.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ wm.x <- as.integer( tclvalue( tkwinfo("x", janela.principal) ) )
+ wm.y <- as.integer( tclvalue( tkwinfo("y", janela.principal) ) )
+
+ new.wm.x <- wm.x + wm.main.width/2 - wm.child.width/2
+ new.wm.y <- wm.y + wm.main.height/2 - wm.child.height/2
+
+ new.wm.x <- round(new.wm.x)
+ new.wm.y <- round(new.wm.y)
+
+ limite.sup.x <- round( MAX.width - wm.child.width )
+ limite.inf.x <- round( wm.child.width )
+ limite.sup.y <- round( MAX.height - wm.child.height )
+ limite.sup.y <- round( wm.child.height )
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$\%#$\%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.child.width, "x", wm.child.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/posiciona.janela.no.mouse.Rd
===================================================================
--- pkg/man/posiciona.janela.no.mouse.Rd (rev 0)
+++ pkg/man/posiciona.janela.no.mouse.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,71 @@
+\name{posiciona.janela.no.mouse}
+\alias{posiciona.janela.no.mouse}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+posiciona.janela.no.mouse(janela.nova, wm.width = -1, wm.height = -1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{janela.nova}{ ~~Describe \code{janela.nova} here~~ }
+ \item{wm.width}{ ~~Describe \code{wm.width} here~~ }
+ \item{wm.height}{ ~~Describe \code{wm.height} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(janela.nova, wm.width = -1, wm.height = -1) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.nova) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.nova) ) )
+
+ if (wm.height == -1) wm.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ if (wm.width == -1) wm.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ mouse.x.pos <- as.integer( tclvalue( tkwinfo("pointerx", janela.nova) ) )
+ mouse.y.pos <- as.integer( tclvalue( tkwinfo("pointery", janela.nova) ) )
+
+ new.wm.x <- round( mouse.x.pos - wm.width/2 )
+ new.wm.y <- round( mouse.y.pos - wm.height/2 )
+
+ limite.sup.x <- round( MAX.width - wm.width/2 )
+ limite.inf.x <- 0
+ limite.sup.y <- round( MAX.height - wm.height/2 )
+ limite.inf.y <- 0
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$\%#$\%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y < limite.inf.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.width, "x", wm.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/posiciona.janela.tela.Rd
===================================================================
--- pkg/man/posiciona.janela.tela.Rd (rev 0)
+++ pkg/man/posiciona.janela.tela.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,66 @@
+\name{posiciona.janela.tela}
+\alias{posiciona.janela.tela}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+posiciona.janela.tela(janela.nova)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{janela.nova}{ ~~Describe \code{janela.nova} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(janela.nova) {
+ MAX.height <- as.integer( tclvalue( tkwinfo("screenheight", janela.nova) ) )
+ MAX.width <- as.integer( tclvalue( tkwinfo("screenwidth", janela.nova) ) )
+
+ wm.height <- as.integer( tclvalue( tkwinfo("height", janela.nova) ) )
+ wm.width <- as.integer( tclvalue( tkwinfo("width", janela.nova) ) )
+
+ new.wm.y <- round( MAX.height/2 - wm.height/2 )
+ new.wm.x <- round( MAX.width/2 - wm.width/2 )
+
+ limite.sup.x <- round( MAX.width - wm.width )
+ limite.inf.x <- 0
+ limite.sup.y <- round( MAX.height - wm.height )
+ limite.inf.y <- 0
+
+ # Limitantes para o tamanho da tela. Quem tem tela virtural... #$\%#$\%
+ if (new.wm.x > limite.sup.x) new.wm.x <- limite.sup.x
+ if (new.wm.x < limite.inf.x) new.wm.x <- limite.inf.x
+ if (new.wm.y > limite.sup.y) new.wm.y <- limite.sup.y
+ if (new.wm.y < limite.inf.y) new.wm.y <- limite.sup.y
+
+ posicao <- paste(wm.width, "x", wm.height, "+", new.wm.x,"+", new.wm.y, sep="")
+ tkwm.geometry(janela.nova,posicao)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/probString2Numeric.Rd
===================================================================
--- pkg/man/probString2Numeric.Rd (rev 0)
+++ pkg/man/probString2Numeric.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,55 @@
+\name{probString2Numeric}
+\alias{probString2Numeric}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+probString2Numeric(probMAT)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{probMAT}{ ~~Describe \code{probMAT} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(probMAT) {
+ n.lin <- dim(probMAT)[1]
+ n.col <- dim(probMAT)[2]
+
+ ans <- matrix(, n.lin, n.col)
+
+ for (i in 1:n.lin) {
+ for (j in 1:n.col) {
+ ans[i,j] <- exec.text(probMAT[i,j])
+ }
+ }
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/probability.check.Rd
===================================================================
--- pkg/man/probability.check.Rd (rev 0)
+++ pkg/man/probability.check.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,70 @@
+\name{probability.check}
+\alias{probability.check}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+probability.check(k)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{k}{ ~~Describe \code{k} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(k) {
+ names(k) <- c("Level", "Node.N", "Node.name", "Father", "Father.Name",
+ "Prob", "Type", "Note", "Destiny", "Payoff1", "Payoff2")
+ Levels <- 2:max(k$Level)
+ variables <- names(k)
+
+ ans <- ""
+ for (i in Levels) {
+ Data <- subset(k, Level == i, select = variables)
+ nodes <- as.numeric(names(table(Data$Father)))
+ for (j in nodes) {
+ Data2 <- subset(Data, Father == j, select = variables)
+ psum <- sum(Data2$Prob)
+ if (psum != 1) {
+ nome.pai <- Data2$Father.Name[1]
+ ans <- paste(ans,
+ "Há problema em [ NÍVEL = ", i-1, ", NODO = ", nome.pai, " ] \n", sep = "")
+ }
+ }
+ }
+ ans2 <- "1"
+ if (nchar(ans) == 0) {
+ ans <- "As probabilidades somam 1. Tudo ok!"
+ ans2 <- "0"
+ }
+
+ return(c(ans,ans2))
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/probwindows.Rd
===================================================================
--- pkg/man/probwindows.Rd (rev 0)
+++ pkg/man/probwindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,89 @@
+\name{probwindows}
+\alias{probwindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+probwindows()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ probWindow <- tktoplevel()
+ title <- "ÁrvoRe - Probabilidade Nodo"
+ tkwm.title(probWindow,title)
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ Probvar <- tclVar(TheTree$Prob[position])
+
+ entry.Value <- tkentry(probWindow,width="20",textvariable=Probvar)
+ tkgrid(tklabel(probWindow,text="Probabilidade"))
+ tkgrid(entry.Value)
+ OnOK <- function()
+ {
+ ProbVal <- as.numeric(tclvalue(Probvar))
+ if ( (is.numeric(ProbVal)) && (!is.na(ProbVal)) && (ProbVal <= 1) && (ProbVal >= 0) ) {
+ tkdestroy(probWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setprob(TheTree, nodeSec[2], nodeSec[3], ProbVal, .EnvironmentArvoRe)
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor de probabilidade válido '",ProbVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(probWindow)
+ }
+ }
+ OK.but <-tkbutton(probWindow,text=" OK ",command=OnOK)
+ tkbind(entry.Value, "<Return>",OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(probWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(probWindow,text=" Cancel ",command=OnCancel)
+ tkbind(probWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(probWindow, 200, 100)
+ tkfocus(probWindow)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/properties.tree.Rd
===================================================================
--- pkg/man/properties.tree.Rd (rev 0)
+++ pkg/man/properties.tree.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,225 @@
+\name{properties.tree}
+\alias{properties.tree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+properties.tree(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ propertiesWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(propertiesWindow,title)
+
+ tclRequire("BWidget")
+
+ frameOverall <- tkframe(propertiesWindow)
+ frameLeft <- tkframe(frameOverall)
+ frameRight <- tkframe(frameOverall)
+ titleframe <- "Método de Cálculo"
+ frameUpper <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Simulação 1-st order"
+ frameSimUpper <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Formato Numérico"
+ frameNumeric <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Formato da árvore"
+ frameTreePlot <- tkwidget(frameLeft, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ titleframe <- "Exibir na árvore"
+ frameTreePlotElements <- tkwidget(frameRight, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+ titleframe <- "Fontes da árvore"
+ frameFontPlot <- tkwidget(frameRight, "labelframe", borderwidth = 2, relief = "groove", text = titleframe)
+
+ ### Method settings ###
+ metodos <- c("Simple Decision (simple payoff)", "Cost-Effectiveness")
+ method.arvore <- c("SD", "CE")
+
+ methodBox <- tkwidget(frameUpper, "ComboBox", editable=FALSE, values=metodos, width = 30)
+ labelmethodBox <- tklabel(frameUpper,text="Método")
+ tkgrid(labelmethodBox, methodBox, sticky = "nw", padx = 5, pady = 5)
+
+ if (.modeltypeArvore == "SD") {
+ selected.method <- "@0"
+ } else {
+ if (.modeltypeArvore == "CE") selected.method <- "@1"
+ }
+ tcl(methodBox, "setvalue", selected.method)
+
+ ### Numeric format settings ###
+ numericSpinBox <- tkwidget(frameNumeric, "SpinBox", editable=FALSE, range = c(0,10,1), width = 3)
+ labeldigits <- tklabel(frameNumeric,text="Número de casas decimais")
+ tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(numericSpinBox, "setvalue", paste("@", .digits,sep = ""))
+
+ ### Simulation settings ###
+ absorventstatecb <- tkcheckbutton(frameSimUpper)
+ absorventstatecbValue <- tclVar(.absorventstateconf)
+ tkconfigure(absorventstatecb, variable = absorventstatecbValue)
+ tkgrid(absorventstatecb, tklabel(frameSimUpper,text = "Interpretar estado absorvente como morte"))
+
+ ### Tree Plot ###
+# ("squared", "normal")
+ tkgrid(tklabel(frameTreePlot,text="Ângulos das linhas das ramificação"), row = 0, column = 0, columnspan = 2, sticky = "w")
+
+ rb1 <- tkradiobutton(frameTreePlot)
+ tpValue <- tclVar(.treeangle)
+ tkconfigure(rb1, variable = tpValue, value = "squared")
+ tkgrid(rb1, row = 3, column = 0, sticky = "w")
+ tkgrid(tklabel( frameTreePlot,text="Retos"), row = 3, column = 1, sticky = "w")
+
+ rb2 <- tkradiobutton(frameTreePlot)
+ tkconfigure(rb2, variable = tpValue, value = "normal")
+ tkgrid(rb2, row = 4, column = 0, sticky = "w")
+ tkgrid(tklabel(frameTreePlot,text="Normais"), row = 4, column = 1, sticky = "w")
+
+ ### Tree Plot Elements ###
+# tkgrid(tklabel(frameTreePlotElements,text="Exibir na árvore"), row = 0, column = 0, columnspan = 2)
+
+ notescb <- tkcheckbutton(frameTreePlotElements)
+ notescbValue <- tclVar(.notesconf)
+ tkconfigure(notescb, variable = notescbValue)
+ tkgrid(notescb, tklabel(frameTreePlotElements,text="Comentários"))
+
+ probabilitycb <- tkcheckbutton(frameTreePlotElements)
+ probabilitycbValue <- tclVar(.probabilityconf)
+ tkconfigure(probabilitycb, variable = probabilitycbValue)
+ tkgrid(probabilitycb, tklabel(frameTreePlotElements,text="Probabilidades"))
+
+ payoffscb <- tkcheckbutton(frameTreePlotElements)
+ payoffscbValue <- tclVar(.payoffsconf)
+ tkconfigure(payoffscb, variable = payoffscbValue)
+ tkgrid(payoffscb, tklabel(frameTreePlotElements,text="Payoffs"))
+
+ tkgrid(frameUpper, sticky="nwe")
+ tkgrid(frameNumeric, sticky="nwe")
+ tkgrid(frameSimUpper, sticky="nwe")
+ tkgrid(frameTreePlot, sticky="nwe")
+ tkgrid(frameTreePlotElements, sticky="nwe")
+ tkgrid(frameFontPlot, sticky="nwe")
+
+ ### Tree Plot Font ###
+ font.nameSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Nome do nodo")
+ tkgrid(labeldigits, font.nameSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.nameSpinBox, "setvalue", paste("@", .node.name.font.size, sep = ""))
+
+ font.payoffsSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Payoffs (custo e efetividade)")
+ tkgrid(labeldigits, font.payoffsSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", .payoffs.font.size, sep = ""))
+
+ font.notesSpinBox <- tkwidget(frameFontPlot, "SpinBox", editable=FALSE, range = c(0,72,1), width = 3)
+ labeldigits <- tklabel(frameFontPlot,text="Comentários do nodo")
+ tkgrid(labeldigits, font.notesSpinBox, sticky = "nw", padx = 5, pady = 5)
+ tcl(font.notesSpinBox, "setvalue", paste("@", .notes.font.size, sep = ""))
+
+ # Configurações para o tamanho dos botões.
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OnDefault.font <- function () {
+ tcl(font.nameSpinBox, "setvalue", paste("@", 12, sep = ""))
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", 6, sep = ""))
+ tcl(font.notesSpinBox, "setvalue", paste("@", 6, sep = ""))
+ }
+
+ OnRestore.font <- function () {
+ tcl(font.nameSpinBox, "setvalue", paste("@", .node.name.font.size, sep = ""))
+ tcl(font.payoffsSpinBox, "setvalue", paste("@", .payoffs.font.size, sep = ""))
+ tcl(font.notesSpinBox, "setvalue", paste("@", .notes.font.size, sep = ""))
+ }
+
+ Restore.font <-tkbutton(frameFontPlot,text="Restaurar", width=.Width.but, height=.Height.but, command=OnRestore.font)
+# tkgrid(Default.font, sticky = "sw", padx = 5, pady = 5)
+
+ Default.font <-tkbutton(frameFontPlot,text="Padrão", width=.Width.but, height=.Height.but, command=OnDefault.font)
+ tkgrid(Restore.font, Default.font, sticky = "sw", padx = 5, pady = 5)
+
+ OnOK <- function()
+ {
+ methodChoice <- method.arvore[as.numeric(tclvalue(tcl(methodBox,"getvalue")))+1]
+ assign(".modeltypeArvore", methodChoice, .EnvironmentArvoRe)
+
+ .digits <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue")))
+ if ((is.numeric(.digits) )&&(!is.na(.digits))) assign(".digits", .digits, .EnvironmentArvoRe)
+
+ .treeangle <- tclvalue(tpValue)
+ assign(".treeangle", .treeangle, .EnvironmentArvoRe)
+
+ .absorventstateconf <- as.numeric(as.character(tclvalue(absorventstatecbValue)))
+ assign(".absorventstateconf", .absorventstateconf, .EnvironmentArvoRe)
+
+ .notesconf <- as.numeric(as.character(tclvalue(notescbValue)))
+ assign(".notesconf", .notesconf, .EnvironmentArvoRe)
+
+ .probabilityconf <- as.numeric(as.character(tclvalue(probabilitycbValue)))
+ assign(".probabilityconf", .probabilityconf, .EnvironmentArvoRe)
+
+ .payoffsconf <- as.numeric(as.character(tclvalue(payoffscbValue)))
+ assign(".payoffsconf", .payoffsconf, .EnvironmentArvoRe)
+
+ .node.name.font.size <- as.numeric(tclvalue(tcl(font.nameSpinBox,"getvalue")))
+ if ((is.numeric(.node.name.font.size) )&&(!is.na(.node.name.font.size))) assign(".node.name.font.size", .node.name.font.size, .EnvironmentArvoRe)
+
+ .payoffs.font.size <- as.numeric(tclvalue(tcl(font.payoffsSpinBox,"getvalue")))
+ if ((is.numeric(.payoffs.font.size) )&&(!is.na(.payoffs.font.size))) assign(".payoffs.font.size", .payoffs.font.size, .EnvironmentArvoRe)
+
+ .notes.font.size <- as.numeric(tclvalue(tcl(font.notesSpinBox,"getvalue")))
+ if ((is.numeric(.notes.font.size) )&&(!is.na(.notes.font.size))) assign(".notes.font.size", .notes.font.size, .EnvironmentArvoRe)
+
+ tkdestroy(propertiesWindow)
+ refreshF5()
+ tkfocus(tt)
+ }
+ OnCancel <- function() {
+ tkdestroy(propertiesWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+ tkbind(propertiesWindow, "<Return>",OnOK)
+ tkbind(propertiesWindow, "<Escape>",OnCancel)
+
+ tkgrid(frameLeft, frameRight, ipadx = 6, sticky="nwe")
+ tkgrid(frameLower, sticky="nwe", columnspan = 2)
+ tkgrid(frameOverall)
+
+ tkfocus(propertiesWindow)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/refreshF5.Rd
===================================================================
--- pkg/man/refreshF5.Rd (rev 0)
+++ pkg/man/refreshF5.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,49 @@
+\name{refreshF5}
+\alias{refreshF5}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+refreshF5(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ clearTreeTkArvore(TheTree)
+ theTreeTkArvore(TheTree)
+ atualiza.grafico()
+ tcl(treeWidget,"opentree", "1.1") # Expande a árvore
+ settreevartype(TheTree) # para ajustar os tipos de variáveis no TheTree.
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/remove.node.Rd
===================================================================
--- pkg/man/remove.node.Rd (rev 0)
+++ pkg/man/remove.node.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,125 @@
+\name{remove.node}
+\alias{remove.node}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+remove.node(TheTree, node.col, node.number)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{node.col}{ ~~Describe \code{node.col} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, node.col, node.number) {
+ removelines <- select.subtree(TheTree, node.col, node.number, change.row.names = FALSE)
+ removelines <- rownames(removelines)
+
+ num.lin <- dim(TheTree)[1]
+
+ whoiwant <- as.numeric(setdiff(as.character(1:num.lin), removelines))
+
+ ans <- TheTree[whoiwant,]
+
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+
+ position <- which(ans$Level == 2)
+
+if( ( length(position) > 1 ) && ( dim(ans)[1] > 2 )) {
+ #- Correção para o primeiro do nível ---------------------------------------------------------------
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) != 1 ) &&
+ ( as.numeric(ans$Level[i]) > as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i]
+ ans$Node.N[i] <- 1
+ usedlevel <- ans$Level[i] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- ans$Node.N[i]
+ ans$Father.Name[position] <- ans$Node.name[i]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+
+ #- Correção para numeracao dos nodos -------------------------------------------------------------
+ .stopit <- FALSE
+ i <- 1
+ nans <- dim(ans)[1]
+ while ( !.stopit ) {
+ i <- i + 1
+ GTtflag <- ( as.numeric(ans$Node.N[i]) > as.numeric(ans$Node.N[i-1])+1 ) &&
+ ( as.numeric(ans$Level[i]) == as.numeric(ans$Level[i-1]) )
+ if (GTtflag) {
+ old.value <- ans$Node.N[i]
+ ans$Node.N[i] <- ans$Node.N[i-1] + 1
+ usedlevel <- ans$Level[i-1] + 1
+ position <- intersect(which(ans$Level == usedlevel),which(ans$Father == old.value))
+ if ( length(position) > 0) {
+ ans$Father[position] <- old.value
+ ans$Father.Name[position] <- ans$Node.name[i-1]
+ }
+ ans <- ans[ order(ans$Level,ans$Father, ans$Node.N),]
+ i <- 1
+ } else {
+ if (i >= nans) .stopit <- TRUE
+ }
+ }
+ #--------------------------------------------------------------------------------------------------
+ }
+ rownames(ans) <- NULL
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/removenodewindows.Rd
===================================================================
--- pkg/man/removenodewindows.Rd (rev 0)
+++ pkg/man/removenodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,72 @@
+\name{removenodewindows}
+\alias{removenodewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+removenodewindows(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ node.col <- as.numeric(nodeSec[2])
+ if (node.col > 1) {
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ Removenamevar <- TheTree$Node.name[position]
+
+ msg <- paste("Deseja realmente excluir o nodo '", Removenamevar, "'?", sep = "")
+ ans <- tkmessageBox(message=msg, icon="question",type="yesnocancel",default="no")
+ ans <- as.character(tclvalue(ans))
+ if (ans == "yes") {
+ NewTheTree <- remove.node(TheTree, node.col, node.number)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setremovenode(NewTheTree, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ }
+ } else {
+ msg <- paste("Não é possível remover o nodo raiz.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ }
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/rollback.Rd
===================================================================
--- pkg/man/rollback.Rd (rev 0)
+++ pkg/man/rollback.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,93 @@
+\name{rollback}
+\alias{rollback}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+rollback(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+
+ x <- Matrixset$x
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+
+ num.col <- dim(probMAT)[2]
+ num.lin <- dim(probMAT)[1]
+
+ ans.ce <- matrix(0, num.lin, num.col)
+ ans.cost <- matrix(0, num.lin, num.col)
+ ans.effectiveness <- matrix(0, num.lin, num.col)
+
+ for (i in 1:(num.col)) {
+ nodes <- as.numeric(names(table(x[,i])))
+ for (j in nodes) {
+ position <- which(x[,i] == j)
+ sub.x <- x[position, i:num.col]
+ lines.sub <- length(position)
+ column.sub <- num.col - i + 1
+ sub.x <- matrix(sub.x, lines.sub, column.sub)
+ sub.prob <- probMAT[position, i:num.col]
+ sub.prob <- matrix(sub.prob, lines.sub, column.sub)
+ sub.util <- utilityMAT[position, i:num.col]
+ sub.util <- matrix(sub.util, lines.sub, column.sub)
+ sub.effectiveness <- effectivenessMAT[position, i:num.col]
+ sub.effectiveness <- matrix(sub.effectiveness, lines.sub, column.sub)
+
+ if (is.null(sub.prob)) {
+ sub.prob[,1] <- 1
+ sub.util[,1] <- 0
+ sub.effectiveness[,1] <- 1
+ val.expected.ce <- sum ( apply(sub.prob, 1, prod) * apply(sub.util/sub.effectiveness, 1, sum) )
+ val.expected.cost <- sum ( apply(sub.prob, 1, prod) * apply(sub.util, 1, sum) )
+ val.expected.effectiveness <- sum ( apply(sub.prob, 1, prod) * apply(sub.effectiveness, 1, sum) )
+ } else {
+ sub.prob[,1] <- 1
+ val.expected <- sum ( apply(sub.prob,1,prod) * apply(sub.util/sub.effectiveness,1,sum) )
+ val.expected.cost <- sum ( apply(sub.prob, 1, prod) * apply(sub.util, 1, sum) )
+ val.expected.effectiveness <- sum ( apply(sub.prob, 1, prod) * apply(sub.effectiveness, 1, sum) )
+ }
+ ans.ce[position, i] <- val.expected
+ ans.cost[position, i] <- val.expected.cost
+ ans.effectiveness[position, i] <- val.expected.effectiveness
+ }
+ }
+ ans <- list("CE" = ans.ce, "Cost" = ans.cost, "Effectiveness" = ans.effectiveness)
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/safedofunction.Rd
===================================================================
--- pkg/man/safedofunction.Rd (rev 0)
+++ pkg/man/safedofunction.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,48 @@
+\name{safedofunction}
+\alias{safedofunction}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+ \item{.modeltypeArvore}{ ~~Describe \code{.modeltypeArvore} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .EnvironmentArvoRe, .modeltypeArvore) {
+ assign("TheTree", TheTree, .EnvironmentArvore.Secure)
+ assign(".modeltypeArvore", .modeltypeArvore, .EnvironmentArvore.Secure)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/sair.Rd
===================================================================
--- pkg/man/sair.Rd (rev 0)
+++ pkg/man/sair.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,64 @@
+\name{sair}
+\alias{sair}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+sair()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ ReturnVal <- tkmessageBox(title = "Sair do Programa",
+ message = "Deseja realmente sair do programa?",
+ icon = "question", type = "yesnocancel", default = "no")
+ if (tclvalue(ReturnVal) == "yes") {
+ if (.workstatus == "saved") {
+ tkdestroy(tt)
+ } else {
+ ReturnVal <- tkmessageBox(title = "Sair do Programa", message="Deseja salvar a árvore atual?",
+ icon="question", type="yesnocancel", default="yes")
+ if (tclvalue(ReturnVal) == "yes") {
+ save.file.arv()
+ tkdestroy(tt)
+ } else {
+ tkdestroy(tt)
+ }
+ }
+ # clear all arvoRe objects
+ .final.objects <- objects(envir = .EnvironmentArvoRe, all.names = TRUE)
+ .init.objects <- get(".init.objects", .EnvironmentArvoRe)
+ toremove.objects <- setdiff(.final.objects, .init.objects)
+ rm(list = toremove.objects, envir = .EnvironmentArvoRe)
+ }
+ else tkfocus(tt)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/save.as.file.arv.Rd
===================================================================
--- pkg/man/save.as.file.arv.Rd (rev 0)
+++ pkg/man/save.as.file.arv.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,57 @@
+\name{save.as.file.arv}
+\alias{save.as.file.arv}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+save.as.file.arv(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ fileName<-tclvalue(tkgetSaveFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( ans != ".arv" ) fileName <- paste(fileName, ".arv", sep="")
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/save.file.arv.Rd
===================================================================
--- pkg/man/save.file.arv.Rd (rev 0)
+++ pkg/man/save.file.arv.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,67 @@
+\name{save.file.arv}
+\alias{save.file.arv}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+save.file.arv(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ if ( .opennedfile == "newfile") {
+ fileName <- tclvalue(tkgetSaveFile(filetypes="{{ArvoRe Files} {.arv}} {{All files} *}"))
+ if (!nchar(fileName))
+ tkfocus(tt)
+ else {
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( ans != ".arv" ) fileName <- paste(fileName, ".arv", sep="")
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+ } else {
+ fileName <- .opennedfile
+ save(TheTree, .EnvironmentArvoRe, .modeltypeArvore, markov.propertiesMAT, file = fileName, ascii = TRUE)
+ assign(".workstatus", "saved", .EnvironmentArvoRe)
+ assign(".opennedfile", fileName, .EnvironmentArvoRe)
+ .Windowtitle <- paste("ÁrvoRe - Janela Principal", " - [", .opennedfile, "]", sep = "")
+ tkwm.title(tt, .Windowtitle)
+ tkfocus(tt)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/select.markov.propertiesMAT.Rd
===================================================================
--- pkg/man/select.markov.propertiesMAT.Rd (rev 0)
+++ pkg/man/select.markov.propertiesMAT.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,106 @@
+\name{select.markov.propertiesMAT}
+\alias{select.markov.propertiesMAT}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+select.markov.propertiesMAT(TheTree, SubTree, markov.propertiesMAT)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{SubTree}{ ~~Describe \code{SubTree} here~~ }
+ \item{markov.propertiesMAT}{ ~~Describe \code{markov.propertiesMAT} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, SubTree, markov.propertiesMAT) {
+ require(abind)
+
+ selected.lines <- rownames(SubTree)
+ check.tree <- TheTree[selected.lines,]
+ wanted.level <- check.tree$Level[1]+1
+ check.tree <- check.tree[check.tree$Level == wanted.level,]
+ ans <- data.frame( "Level" = array(,0),
+ "Node.N" = array(,0),
+ "Node.name" = array(,0),
+ "Father" = array(,0),
+ "Father.Name" = array(,0),
+ "Initial.cost" = array(,0),
+ "Incremental.cost" = array(,0),
+ "Final.cost" = array(,0),
+ "Initial.effectiveness" = array(,0),
+ "Incremental.effectiveness" = array(,0),
+ "Final.effectiveness" = array(,0))
+ for (i in 1:length(check.tree$Node.N) ) {
+ balde <- subset(markov.propertiesMAT, Node.N == check.tree$Node.N[i])
+ n.lin.balde <- dim(balde)[1]
+ if (n.lin.balde > 0) {
+ ans <- abind(ans, balde, along = 1)
+ } else {
+ balde <- data.frame( "Level" = check.tree$Level[i],
+ "Node.N" = check.tree$Node.N[i],
+ "Node.name" = check.tree$Node.name[i],
+ "Father" = check.tree$Father[i],
+ "Father.Name" = check.tree$Father.Name[i],
+ "Initial.cost" = 0,
+ "Incremental.cost" = check.tree$Payoff1[i],
+ "Final.cost" = 0,
+ "Initial.effectiveness" = 0,
+ "Incremental.effectiveness" = check.tree$Payoff2[i],
+ "Final.effectiveness" = 0)
+ ans <- abind(ans, balde, along = 1)
+ }
+ }
+ ans <- as.data.frame(ans)
+
+ wanted.level.sub <- SubTree$Level[1]+1
+ subSubTree <- subset(SubTree, Level == wanted.level.sub)
+ ans$Level <- subSubTree$Level
+ ans$Node.N <- subSubTree$Node.N
+ ans$Father <- subSubTree$Father
+ ans$Father.Name <- subSubTree$Father.Name
+ rownames(ans) <- rownames(subSubTree)
+
+ ans$Level <- as.numeric(as.character(ans$Level))
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- (as.character(ans$Node.name))
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- (as.character(ans$Father.Name))
+ ans$Initial.cost <- as.numeric(as.character(ans$Initial.cost))
+ ans$Incremental.cost <- as.numeric(as.character(ans$Incremental.cost))
+ ans$Final.cost <- as.numeric(as.character(ans$Final.cost))
+ ans$Initial.effectiveness <- as.numeric(as.character(ans$Initial.effectiveness))
+ ans$Incremental.effectiveness <- as.numeric(as.character(ans$Incremental.effectiveness))
+ ans$Final.effectiveness <- as.numeric(as.character(ans$Final.effectiveness))
+
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/select.origins.Rd
===================================================================
--- pkg/man/select.origins.Rd (rev 0)
+++ pkg/man/select.origins.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,75 @@
+\name{select.origins}
+\alias{select.origins}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+select.origins(TheTree, node.col, node.number)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{node.col}{ ~~Describe \code{node.col} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, node.col, node.number) {
+ require(abind)
+ position <- intersect(which((TheTree$Level == node.col)),which(TheTree$Node.N == node.number))
+ ans <- TheTree[position,]
+
+ levelnodevalue <- node.col - 1
+ nodenumbervalue <- ans$Father[1] #[position]
+
+ while ( levelnodevalue > 0) {
+ position <- intersect(which((TheTree$Level == levelnodevalue)),which(TheTree$Node.N == nodenumbervalue))
+ subData <- TheTree[position,]
+ ans <- abind(subData, ans, along=1)
+ nodenumbervalue <- subData$Father[1]
+ levelnodevalue <- levelnodevalue - 1
+ }
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(ans$Level)
+ ans$Node.N <- as.numeric(ans$Node.N)
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(ans$Father)
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(ans$Prob)
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/select.subtree.Rd
===================================================================
--- pkg/man/select.subtree.Rd (rev 0)
+++ pkg/man/select.subtree.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,116 @@
+\name{select.subtree}
+\alias{select.subtree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+select.subtree(TheTree, node.col, node.number, change.row.names = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{node.col}{ ~~Describe \code{node.col} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{change.row.names}{ ~~Describe \code{change.row.names} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, node.col, node.number, change.row.names = FALSE) {
+ require(abind)
+ levelmax <- max(TheTree$Level)
+ variables <- names(TheTree)
+
+ ans <- subset(TheTree, Level == node.col, select = variables)
+ ans <- subset(ans, Node.N == node.number, select = variables)
+# print(ans)
+
+ if (node.col != levelmax) {
+ i <- (node.col+1)
+ pais <- node.number
+ while (i != 0) {
+
+ Datatmp <- subset(TheTree, Level == i, select = variables)
+ novos.pais <- array(,0)
+ for (j in pais) {
+ DatatmpP <- subset(Datatmp, Father == j, select = variables)
+ if (dim(DatatmpP)[1] != 0) {
+ ans <- abind(ans, DatatmpP, along=1)
+# print(ans)
+ novos.pais <- c(novos.pais, DatatmpP$Node.N)
+ }
+ }
+ pais <- novos.pais
+
+ if (i == levelmax) {
+ i <- 0
+ } else {
+ i <- i + 1
+ }
+ if( length(pais) == 0) i <- 0
+ }
+ }
+
+ ans <- as.data.frame(ans)
+
+ ans$Level <- as.numeric(ans$Level)
+ ans$Node.N <- as.numeric(as.character(ans$Node.N))
+ ans$Node.name <- as.character(ans$Node.name)
+ ans$Father <- as.numeric(as.character(ans$Father))
+ ans$Father.Name <- as.character(ans$Father.Name)
+ ans$Prob <- as.numeric(as.character(ans$Prob))
+ ans$Type <- as.character(ans$Type)
+ ans$Note <- as.character(ans$Note)
+ ans$Destiny <- as.character(ans$Destiny)
+ ans$Payoff1 <- as.numeric(as.character(ans$Payoff1))
+ ans$Payoff2 <- as.numeric(as.character(ans$Payoff2))
+#
+# # Ajusta a numeração dos nodos
+# levelmax <- max(ans$Level)
+# for (i in 1:levelmax) {
+# positions <- which(ans$Level == i)
+# n.node <- as.numeric(names(table(ans$Node.N[positions])))
+# size.n.node <- length(n.node)
+# for (j in 1:size.n.node) {
+# positions.node.replace <- which(ans$Node.N == n.node[j])
+# positions.node.replace <- intersect(positions, positions.node.replace)
+# ans$Node.N[positions.node.replace] <- j
+# if (i != levelmax) {
+# positions.next.level <- which(ans$Level == (i+1))
+# positions.node.as.father <- which(ans$Father == n.node[j])
+# positions.node.as.father <- intersect(positions.next.level, positions.node.as.father)
+# ans$Father[positions] <- j
+# }
+# }
+# }
+ ans <- ans[ order(ans$Level,ans$Node.N),]
+ if (change.row.names) rownames(ans) <- NULL
+ return(ans)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/set.markov.nodes.properties.Rd
===================================================================
--- pkg/man/set.markov.nodes.properties.Rd (rev 0)
+++ pkg/man/set.markov.nodes.properties.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,114 @@
+\name{set.markov.nodes.properties}
+\alias{set.markov.nodes.properties}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+set.markov.nodes.properties(TheTree, markov.propertiesMAT, column, node.number, Initial.rwd.cost = 0, Incremental.rwd.cost = 0, Final.rwd.cost = 0, Initial.rwd.effectiveness = 1, Incremental.rwd.effectiveness = 1, Final.rwd.effectiveness = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{markov.propertiesMAT}{ ~~Describe \code{markov.propertiesMAT} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{Initial.rwd.cost}{ ~~Describe \code{Initial.rwd.cost} here~~ }
+ \item{Incremental.rwd.cost}{ ~~Describe \code{Incremental.rwd.cost} here~~ }
+ \item{Final.rwd.cost}{ ~~Describe \code{Final.rwd.cost} here~~ }
+ \item{Initial.rwd.effectiveness}{ ~~Describe \code{Initial.rwd.effectiveness} here~~ }
+ \item{Incremental.rwd.effectiveness}{ ~~Describe \code{Incremental.rwd.effectiveness} here~~ }
+ \item{Final.rwd.effectiveness}{ ~~Describe \code{Final.rwd.effectiveness} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, markov.propertiesMAT, column, node.number,
+ Initial.rwd.cost = 0,
+ Incremental.rwd.cost = 0,
+ Final.rwd.cost = 0,
+ Initial.rwd.effectiveness = 1,
+ Incremental.rwd.effectiveness = 1,
+ Final.rwd.effectiveness = 1 ) {
+
+ require(abind)
+
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position.markov <- intersect(which((markov.propertiesMAT$Level == column)),
+ which(markov.propertiesMAT$Node.N == node.number))
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ if (length(position.markov) != 0) {
+ markov.propertiesMAT$Node.name[position.markov] <- TheTree$Node.name[position]
+ markov.propertiesMAT$Father[position.markov] <- TheTree$Father[position]
+ markov.propertiesMAT$Father.Name[position.markov] <- TheTree$Father.Name[position]
+ markov.propertiesMAT$Initial.cost[position.markov] <- Initial.rwd.cost
+ markov.propertiesMAT$Incremental.cost[position.markov] <- Incremental.rwd.cost
+ markov.propertiesMAT$Final.cost[position.markov] <- Final.rwd.cost
+ markov.propertiesMAT$Initial.effectiveness[position.markov] <- Initial.rwd.effectiveness
+ markov.propertiesMAT$Incremental.effectiveness[position.markov] <- Incremental.rwd.effectiveness
+ markov.propertiesMAT$Final.effectiveness[position.markov] <- Final.rwd.effectiveness
+ } else {
+ markov.propertiesLINE <- data.frame("Level" = column,
+ "Node.N" = node.number,
+ "Node.name" = TheTree$Node.name[position],
+ "Father" = TheTree$Father[position],
+ "Father.Name" = TheTree$Father.Name[position],
+ "Initial.cost" = Initial.rwd.cost,
+ "Incremental.cost" = Incremental.rwd.cost,
+ "Final.cost" = Final.rwd.cost,
+ "Initial.effectiveness" = Initial.rwd.effectiveness,
+ "Incremental.effectiveness" = Incremental.rwd.effectiveness,
+ "Final.effectiveness" = Final.rwd.effectiveness)
+ markov.propertiesMAT <- abind(markov.propertiesMAT, markov.propertiesLINE, along=1)
+ markov.propertiesMAT <- as.data.frame(markov.propertiesMAT)
+
+ markov.propertiesMAT$Level <- as.numeric(as.character(markov.propertiesMAT$Level))
+ markov.propertiesMAT$Node.N <- as.numeric(as.character(markov.propertiesMAT$Node.N))
+ markov.propertiesMAT$Node.name <- (as.character(markov.propertiesMAT$Node.name))
+ markov.propertiesMAT$Father <- as.numeric(as.character(markov.propertiesMAT$Father))
+ markov.propertiesMAT$Father.Name <- (as.character(markov.propertiesMAT$Father.Name))
+ markov.propertiesMAT$Initial.cost <- as.numeric(as.character(markov.propertiesMAT$Initial.cost))
+ markov.propertiesMAT$Incremental.cost <- as.numeric(as.character(markov.propertiesMAT$Incremental.cost))
+ markov.propertiesMAT$Final.cost <- as.numeric(as.character(markov.propertiesMAT$Final.cost))
+ markov.propertiesMAT$Initial.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Initial.effectiveness))
+ markov.propertiesMAT$Incremental.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Incremental.effectiveness))
+ markov.propertiesMAT$Final.effectiveness <- as.numeric(as.character(markov.propertiesMAT$Final.effectiveness))
+
+ }
+
+ setutility(TheTree, column, node.number, Incremental.rwd.cost, .EnvironmentArvoRe)
+ TheTree <- get("TheTree", .EnvironmentArvoRe)
+ seteffectiveness(TheTree, column, node.number, Incremental.rwd.effectiveness, .EnvironmentArvoRe)
+
+ assign("markov.propertiesMAT", markov.propertiesMAT, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/set.model.type.Rd
===================================================================
--- pkg/man/set.model.type.Rd (rev 0)
+++ pkg/man/set.model.type.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,51 @@
+\name{set.model.type}
+\alias{set.model.type}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+set.model.type(typemodel)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{typemodel}{ ~~Describe \code{typemodel} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(typemodel) {
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ if (( typemodel == "CE")||( typemodel == "SD")) {
+ assign(".modeltypeArvore", typemodel, .EnvironmentArvoRe)
+ } else {
+ cat("Error!! \n")
+ }
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/set.value.Rd
===================================================================
--- pkg/man/set.value.Rd (rev 0)
+++ pkg/man/set.value.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,184 @@
+\name{set.value}
+\alias{set.value}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+set.value(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ node.type <- TheTree$Type[position]
+ node.name <- TheTree$Node.name[position]
+
+ setvalueWindow <- tktoplevel()
+ title <- "ÁrvoRe - Propriedades"
+ tkwm.title(setvalueWindow,title)
+
+ # Create frames
+ FrameOverall <- tkframe(setvalueWindow, borderwidth = 0, relief = "groove")
+ FrameLeft <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+ FrameRight <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+ FrameButton <- tkframe(FrameRight, borderwidth = 2, relief = "groove")
+ FrameMenuButton <- tkframe(FrameLeft, borderwidth = 2, relief = "groove")
+ FrameLower <- tkframe(FrameOverall, borderwidth = 0, relief = "groove")
+
+ # Node label
+ text.to.label <- paste("Nodo : ", node.name, sep = "")
+ node.tk.label <- tklabel(FrameLeft, text = text.to.label)
+ if (node.type == "C") node.type.label <- "Chance"
+ else if (node.type == "T") node.type.label <- "Terminal"
+ else if (node.type == "M") node.type.label <- "Markov"
+ else if (node.type == "D") node.type.label <- "Decision"
+ else node.type.label <- "Unknow"
+
+ text.to.label <- paste("Tipo : ", node.type.label, sep = "")
+ node.tk.type <- tklabel(FrameLeft, text = text.to.label)
+
+ tkgrid(node.tk.label, sticky = "nw", columnspan = 2)
+ tkgrid(node.tk.type, sticky = "nw", columnspan = 2)
+
+ # The menubutton width
+ menubutton.width <- 15
+
+######### O menubutton
+ Operators <- tkmenubutton(FrameMenuButton, text = "Operadores", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuOperatorsChild <- tkmenu(Operators, tearoff=FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuOperatorsChild,"command",label=">",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="<",command=function() {})
+ tkadd(menuOperatorsChild,"command",label=">=",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="<=",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="==",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="&&",command=function() {})
+ tkadd(menuOperatorsChild,"command",label="||",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="(",command=function() {})
+ tkadd(menuOperatorsChild,"command",label=")",command=function() {})
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"separator")
+ tkadd(menuOperatorsChild,"command",label="Sair",command=function() tkdestroy(setvalueWindow))
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Operators, menu = menuOperatorsChild)
+ # Monta o rótulo e o checkbutton
+
+
+######### O menubutton
+ Functions <- tkmenubutton(FrameMenuButton, text = "Funções", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuFunctionsChild <- tkmenu(Functions, tearoff = FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuFunctionsChild,"command",label="X",command=function() {})
+ tkadd(menuFunctionsChild,"command",label="XX",command=function() {})
+ tkadd(menuFunctionsChild,"separator")
+ tkadd(menuFunctionsChild,"command",label="XXX",command=function() {})
+ tkadd(menuFunctionsChild,"command",label="XXXX",command=function() {})
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Functions, menu = menuFunctionsChild)
+
+######### O menubutton
+ Keywords <- tkmenubutton(FrameMenuButton, text = "Palavra chave", direction = "below",
+ borderwidth = 1, relief = "raised", indicatoron = TRUE,
+ width = menubutton.width)
+######### O menu associado ao menubutton
+ menuKeywordsChild <- tkmenu(Keywords, tearoff = FALSE)
+ # Os ítens do ítem "Botão de menu"
+ tkadd(menuKeywordsChild,"command",label=".stage",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.cost",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.eff",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".stage.reward",command=function() {})
+ tkadd(menuKeywordsChild,"separator")
+ tkadd(menuKeywordsChild,"command",label=".total.cost",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".total.eff",command=function() {})
+ tkadd(menuKeywordsChild,"command",label=".total.reward",command=function() {})
+ tkadd(menuKeywordsChild,"command",label="NONE",command=function() {})
+ # Ajusta que o menu associado ao menubutton é menufilho
+ tkconfigure(Keywords, menu = menuKeywordsChild)
+
+ # Monta os menubuttons
+ tkgrid(Operators, Functions, Keywords, sticky = "n", padx = 5, pady = 5)
+
+ Text.space <- tktext(FrameLeft, borderwidth = 2, relief = "sunken",
+ height = 5, width = 30, wrap = "word")
+
+
+
+ OnOK <- function()
+ {
+
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(setvalueWindow)
+ tkfocus(tt)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(FrameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(FrameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkbind(setvalueWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(FrameButton, sticky = "nwe")
+ tkgrid(FrameMenuButton, sticky = "nwe")
+ tkgrid(Text.space, sticky = "swe", padx = 5, pady = 5)
+ tkgrid(FrameLeft, FrameRight, sticky = "nwe")
+ tkgrid(FrameLower, sticky = "swe")
+ tkgrid(FrameOverall)
+
+ tkfocus(setvalueWindow)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/set.zoom.image.tree.Rd
===================================================================
--- pkg/man/set.zoom.image.tree.Rd (rev 0)
+++ pkg/man/set.zoom.image.tree.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,50 @@
+\name{set.zoom.image.tree}
+\alias{set.zoom.image.tree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+set.zoom.image.tree(imgHeight, imgWidth, scalarfac = 1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{imgHeight}{ ~~Describe \code{imgHeight} here~~ }
+ \item{imgWidth}{ ~~Describe \code{imgWidth} here~~ }
+ \item{scalarfac}{ ~~Describe \code{scalarfac} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(imgHeight, imgWidth, scalarfac = 1) {
+ imgHeight <- imgHeight * scalarfac
+ imgWidth <- imgWidth * scalarfac
+ assign("imgHeight", imgHeight, .EnvironmentArvoRe)
+ assign("imgWidth", imgWidth, .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setaddnode.Rd
===================================================================
--- pkg/man/setaddnode.Rd (rev 0)
+++ pkg/man/setaddnode.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,47 @@
+\name{setaddnode}
+\alias{setaddnode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setaddnode(TheTree, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setdestinynode.Rd
===================================================================
--- pkg/man/setdestinynode.Rd (rev 0)
+++ pkg/man/setdestinynode.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,47 @@
+\name{setdestinynode}
+\alias{setdestinynode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setdestinynode(TheTree, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/seteffectiveness.Rd
===================================================================
--- pkg/man/seteffectiveness.Rd (rev 0)
+++ pkg/man/seteffectiveness.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,58 @@
+\name{seteffectiveness}
+\alias{seteffectiveness}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+seteffectiveness(TheTree, column, node.number, pvalue, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{pvalue}{ ~~Describe \code{pvalue} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Payoff2[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setnodename.Rd
===================================================================
--- pkg/man/setnodename.Rd (rev 0)
+++ pkg/man/setnodename.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,65 @@
+\name{setnodename}
+\alias{setnodename}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setnodename(TheTree, column, node.number, nodename, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{nodename}{ ~~Describe \code{nodename} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, nodename, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+# old.father.name <- TheTree$Node.name[position]
+ TheTree$Node.name[position] <- nodename
+
+ position <- intersect(which((TheTree$Level == (column+1) )),which(TheTree$Father == node.number))
+
+ if (length(position) >= 1) {
+ TheTree$Father.Name[position] <- nodename
+ }
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setnotesnode.Rd
===================================================================
--- pkg/man/setnotesnode.Rd (rev 0)
+++ pkg/man/setnotesnode.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,55 @@
+\name{setnotesnode}
+\alias{setnotesnode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setnotesnode(TheTree, column, node.number, nodo.note, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{nodo.note}{ ~~Describe \code{nodo.note} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, nodo.note, .EnvironmentArvoRe) {
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Note[position] <- nodo.note
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setprob.Rd
===================================================================
--- pkg/man/setprob.Rd (rev 0)
+++ pkg/man/setprob.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,59 @@
+\name{setprob}
+\alias{setprob}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setprob(TheTree, column, node.number, pvalue, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{pvalue}{ ~~Describe \code{pvalue} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Prob[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ refreshF5()
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setremovenode.Rd
===================================================================
--- pkg/man/setremovenode.Rd (rev 0)
+++ pkg/man/setremovenode.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,47 @@
+\name{setremovenode}
+\alias{setremovenode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setremovenode(TheTree, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, .EnvironmentArvoRe) {
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/settreevartype.Rd
===================================================================
--- pkg/man/settreevartype.Rd (rev 0)
+++ pkg/man/settreevartype.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,56 @@
+\name{settreevartype}
+\alias{settreevartype}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+settreevartype(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ TheTree$Level <- as.numeric(TheTree$Level)
+ TheTree$Node.N <- as.numeric(TheTree$Node.N)
+ TheTree$Node.name <- as.character(TheTree$Node.name)
+ TheTree$Father <- as.numeric(TheTree$Father)
+ TheTree$Father.Name <- as.character(TheTree$Father.Name)
+ TheTree$Prob <- as.numeric(TheTree$Prob)
+ TheTree$Type <- as.character(TheTree$Type)
+ TheTree$Note <- as.character(TheTree$Note)
+ TheTree$Destiny <- as.character(TheTree$Destiny)
+ TheTree$Payoff1 <- as.numeric(as.character(TheTree$Payoff1))
+ TheTree$Payoff2 <- as.numeric(as.character(TheTree$Payoff2))
+ assign("TheTree", TheTree, .EnvironmentArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/settypenode.Rd
===================================================================
--- pkg/man/settypenode.Rd (rev 0)
+++ pkg/man/settypenode.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,55 @@
+\name{settypenode}
+\alias{settypenode}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+settypenode(TheTree, column, node.number, nodo.type, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{nodo.type}{ ~~Describe \code{nodo.type} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, nodo.type, .EnvironmentArvoRe) {
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Type[position] <- nodo.type
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setutility.Rd
===================================================================
--- pkg/man/setutility.Rd (rev 0)
+++ pkg/man/setutility.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,58 @@
+\name{setutility}
+\alias{setutility}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setutility(TheTree, column, node.number, pvalue, .EnvironmentArvoRe)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{column}{ ~~Describe \code{column} here~~ }
+ \item{node.number}{ ~~Describe \code{node.number} here~~ }
+ \item{pvalue}{ ~~Describe \code{pvalue} here~~ }
+ \item{.EnvironmentArvoRe}{ ~~Describe \code{.EnvironmentArvoRe} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, column, node.number, pvalue, .EnvironmentArvoRe) {
+ if (!is.numeric(node.number)) node.number <- as.numeric(node.number)
+ if (!is.numeric(column)) column <- as.numeric(column)
+
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ if (length(position) >= 1) {
+ TheTree$Payoff1[position] <- pvalue
+
+ assign("TheTree", TheTree, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/setvariablelist.Rd
===================================================================
--- pkg/man/setvariablelist.Rd (rev 0)
+++ pkg/man/setvariablelist.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,72 @@
+\name{setvariablelist}
+\alias{setvariablelist}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+setvariablelist(variableMAT, newvariableline = " ", variable.name = " ", action = "edit")
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{variableMAT}{ ~~Describe \code{variableMAT} here~~ }
+ \item{newvariableline}{ ~~Describe \code{newvariableline} here~~ }
+ \item{variable.name}{ ~~Describe \code{variable.name} here~~ }
+ \item{action}{ ~~Describe \code{action} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(variableMAT, newvariableline = " ", variable.name = " ", action = "edit") {
+ if (action == "delete") {
+ variables <- names(variableMAT)
+ ans <- subset(variableMAT, Name != variable.name, select = variables)
+ }
+ if (action == "add") {
+ require(abind)
+ ans <- abind(variableMAT, newvariableline, along=1)
+ }
+ if (action == "edit") {
+ variables <- names(variableMAT)
+ ans <- subset(variableMAT, Name != variable.name, select = variables)
+
+ require(abind)
+ ans <- abind(ans, newvariableline, along=1)
+ }
+
+ ans <- as.data.frame(ans)
+ ans$Name <- as.character(ans$Name)
+ ans$Fix.Value <- as.numeric(as.character(ans$Fix.Value))
+ ans$Min.Value <- as.numeric(as.character(ans$Min.Value))
+ ans$Max.Value <- as.numeric(as.character(ans$Max.Value))
+ ans$Notes <- as.character(ans$Notes)
+ assign("variableMAT", ans, envir = .EnvironmentArvoRe)
+ assign(".workstatus", "unsaved", .EnvironmentArvoRe)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/show.prob.check.window.Rd
===================================================================
--- pkg/man/show.prob.check.window.Rd (rev 0)
+++ pkg/man/show.prob.check.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,51 @@
+\name{show.prob.check.window}
+\alias{show.prob.check.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+show.prob.check.window(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ msg <- probability.check(TheTree)
+ icon="error"
+ if (msg[2] == "0") {
+ icon="warning"
+ }
+ tkmessageBox(title = "ÁrvoRe - Verificação das Probabilidades", message=msg[1], icon = icon, type = "ok")
+ tkfocus(tt)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/show.summary.rollback.window.Rd
===================================================================
--- pkg/man/show.summary.rollback.window.Rd (rev 0)
+++ pkg/man/show.summary.rollback.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,54 @@
+\name{show.summary.rollback.window}
+\alias{show.summary.rollback.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+show.summary.rollback.window(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ k <- summary.rollback.table(TheTree)
+
+ names(k) <- c("Nível", "Nodo N", "Nome do nodo",
+ "Custo Esperado", "Efetividade Esperada", "Razão C-E Esperada",
+ "Nome Nodo Pai", "Probabilidade",
+ "Custo", "Efetividade", "Tipo")
+
+ displayInTable(as.matrix(k), title="Valores Esperados (Roll-back)",
+ height=10,width=8,nrow=dim(k)[1],ncol=dim(k)[2],
+ titlerows = FALSE, titlecols = TRUE)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/show.summary.tree.window.Rd
===================================================================
--- pkg/man/show.summary.tree.window.Rd (rev 0)
+++ pkg/man/show.summary.tree.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,49 @@
+\name{show.summary.tree.window}
+\alias{show.summary.tree.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+show.summary.tree.window(...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{\dots}{ ~~Describe \code{\dots} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(...) {
+ k <- TheTree
+
+ displayInTable(as.matrix(k), title="Informação da árvore",
+ height=10,width=8,nrow=dim(k)[1],ncol=dim(k)[2],
+ titlerows = FALSE, titlecols = TRUE)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/simple.markov.coort.table.Rd
===================================================================
--- pkg/man/simple.markov.coort.table.Rd (rev 0)
+++ pkg/man/simple.markov.coort.table.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,101 @@
+\name{simple.markov.coort.table}
+\alias{simple.markov.coort.table}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+simple.markov.coort.table(TheTree, trials = 10000, seed = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{trials}{ ~~Describe \code{trials} here~~ }
+ \item{seed}{ ~~Describe \code{seed} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, trials = 10000, seed = FALSE) {
+ # ajusta a semente escolhida pelo usuário
+ if (seed != FALSE) {
+ set.seed(seed)
+ }
+
+ # Convert the tree to matrix format
+ MatrixTheTree <- convert2matrix(TheTree)
+# print(MatrixTheTree)
+ x <- MatrixTheTree$x # Structure matrix
+ y <- MatrixTheTree$y # Node name matrix
+ typeMAT <- MatrixTheTree$typeMAT # Node type matrix
+ utilityMAT <- MatrixTheTree$utilityMAT # Node Cost matrix
+ effectivenessMAT <- MatrixTheTree$effectivenessMAT # Node effectiveness matrix
+ probMAT <- MatrixTheTree$probMAT # Node probability matrix
+
+ num.col.x <- dim(x)[2]
+ num.lin.x <- dim(x)[1]
+
+ probMAT[,1] <- 1.0 # Agora o nodo raiz recebe prob = 1.
+ typeMAT[,1] <- "D" # Agora o nodo raiz recebe "D".
+
+ # ajusta elementos para matriz... pois com vetor não funciona
+# utilityMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+# effectivenessMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+# probMAT <- matrix(utilityMAT, num.lin.x, num.col.x)
+
+ # ajusta custo e efetividade: serão acumulados através dos nodos.
+ if (num.lin.x > 1) {
+ utilityMAT <- apply(utilityMAT, 1, sum)
+ effectivenessMAT <- apply(effectivenessMAT, 1, sum)
+ } else {
+ utilityMAT <- sum(utilityMAT)
+ effectivenessMAT <- sum(effectivenessMAT)
+ }
+ # cria a tabela que comportará os individuos
+# Coorte.Ind <- matrix(0, 1, trials) # Matriz com cada individuo
+# Coorte.Cost <- matrix(0, 1, trials) # Matriz com custo de cada individuo
+# Coorte.Effec <- matrix(0, 1, trials) # Matriz com a efetividade de cada individuo
+
+ # A simulação em si. Choose your destiny!
+ sorteado <- runif(trials,0,1)
+ linprobs <- cumsum(apply(probMAT, 1, prod)) # observa a probabilidade de cada ramo acontecer numa runif
+ valn <- length(linprobs)
+ linprobs.Matrix <- matrix(linprobs, trials, valn, byrow = TRUE) # podemos ter problema de memória aqui!!!
+ resultado <- valn - apply(sorteado <= linprobs.Matrix, 1, sum) + 1
+# ans.dest <- destinos[resultado] # quantos vão para cada categoria
+ ans.cost <- utilityMAT[resultado]
+ ans.effectiveness <- effectivenessMAT[resultado]
+
+ Coorte.Ind <- matrix(resultado, 1, trials) # Matriz com cada individuo
+ Coorte.Cost <- matrix(ans.cost, 1, trials) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(ans.effectiveness, 1, trials) # Matriz com a efetividade de cada individuo
+
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec)
+ return(ans) # And return the result
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/sobre.Rd
===================================================================
--- pkg/man/sobre.Rd (rev 0)
+++ pkg/man/sobre.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,65 @@
+\name{sobre}
+\alias{sobre}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+sobre(versionarvore, versiondate)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{versionarvore}{ ~~Describe \code{versionarvore} here~~ }
+ \item{versiondate}{ ~~Describe \code{versiondate} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(versionarvore, versiondate) {
+ .Mensagem <- paste(
+" ________________________________________ \n\n",
+" ArvoRe - Análise de Custo Efetividade no R \n",
+" (Simulação de primeira ordem MCMC) \n\n",
+paste("Versão : ", versionarvore, " \n", sep=""),
+paste("Versão : ", versiondate, " \n", sep=""),
+" ________________________________________ \n\n",
+" Autor: \n",
+" Isaías V. Prestes \n",
+" IM - Departamento de Estatística \n",
+" Universidade Federal do Rio Grande do Sul, \n",
+" Av. Bento Gonçalves, 9500, Porto Alegre, Brasil \n",
+" E-mail: isaias.prestes at ufrgs.br \n",
+" URL: http://www.mat.ufrgs.br/~camey/ \n",
+" ________________________________________ \n",
+" \n", sep = "")
+ sobre.wm.title <- "Sobre o Programa"
+ ReturnVal <- tkmessageBox(title = sobre.wm.title,
+ message = .Mensagem, icon = "info", type = "ok")
+ tkfocus(tt)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/splashscreenArvoRe.Rd
===================================================================
--- pkg/man/splashscreenArvoRe.Rd (rev 0)
+++ pkg/man/splashscreenArvoRe.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,56 @@
+\name{splashscreenArvoRe}
+\alias{splashscreenArvoRe}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+splashscreenArvoRe()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ splashArvoRe <- tktoplevel()
+ Width <- 640
+ Height <- 480
+ tkwm.title(splashArvoRe, paste("ÁrvoRe - ", .arvore.version, sep=""))
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/Arvore.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ new.but <- tkbutton(splashArvoRe, image=icn, width=Width, height=Height,
+ command=function() tkdestroy(splashArvoRe))
+ tkgrid(new.but)
+ }
+ }
+ posiciona.janela.tela(splashArvoRe)
+ tcl("tkwait","window",splashArvoRe)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/summary.rollback.table.Rd
===================================================================
--- pkg/man/summary.rollback.table.Rd (rev 0)
+++ pkg/man/summary.rollback.table.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,110 @@
+\name{summary.rollback.table}
+\alias{summary.rollback.table}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+summary.rollback.table(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+ Matrixset <- convert2matrix(TheTree)
+ x <- Matrixset$x
+ y <- Matrixset$y
+ probMAT <- Matrixset$probMAT
+ utilityMAT <- Matrixset$utilityMAT
+ effectivenessMAT <- Matrixset$effectivenessMAT
+ typeMAT <- Matrixset$typeMAT
+
+ rollbackLIST <- rollback(TheTree)
+
+ num.col <- dim(x)[2]
+ num.lin <- dim(x)[1]
+
+ levelnode <- array(,0)
+ paispos <- array(,0)
+ nnode <- array(,0)
+ namenode <- array(,0)
+ probnode <- array(,0)
+ utilitynode <- array(,0)
+ effectivenessnode <- array(,0)
+ typenode <- array(,0)
+ paisnodos.n <- array(,0)
+ paisnodos.name <- array(,0)
+ paisnodos <- array(,0)
+ expectedvalue.cost <- array(,0)
+ expectedvalue.effectiveness <- array(,0)
+ expectedvalue.ce <- array(,0)
+
+ for (i in 1:num.col) {
+ max.node <- max(x[,i], na.rm = TRUE)
+ pais <- 1:max.node
+ for (k in pais) {
+ levelnode <- c(levelnode,i)
+ nodepos <- which(x[,i] == k)[1]
+ paispos <- c(paispos, nodepos)
+ if (i == 1) {
+ paisnodos.n <- c(paisnodos.n, 1)
+ paisnodos.name <- c(paisnodos.name, " ")
+ } else {
+ paisnodos.n <- c(paisnodos.n, x[nodepos, i-1])
+ paisnodos.name <- c(paisnodos.name, y[nodepos, i-1])
+ }
+ nnode <- c(nnode, k)
+ namenode <- c(namenode, y[nodepos, i])
+ probnode <- c(probnode, probMAT[nodepos, i])
+ utilitynode <- c(utilitynode, utilityMAT[nodepos, i])
+ effectivenessnode <- c(effectivenessnode, effectivenessMAT[nodepos, i])
+ typenode <- c(typenode, typeMAT[nodepos, i])
+ expectedvalue.cost <- c(expectedvalue.cost, rollbackLIST[["Cost"]][nodepos, i])
+ expectedvalue.effectiveness <- c(expectedvalue.effectiveness, rollbackLIST[["Effectiveness"]][nodepos, i])
+ expectedvalue.ce <- c(expectedvalue.ce, rollbackLIST[["CE"]][nodepos, i])
+
+ }
+ }
+
+ tabela <- data.frame(Level = levelnode, Node.N = nnode, Node.name = namenode,
+ "Mean Cost" = expectedvalue.cost,
+ "Mean Effectiveness" = expectedvalue.effectiveness,
+ "Mean C-E ratio" = expectedvalue.ce,
+# Father = paisnodos.n,
+ Father.Name = paisnodos.name,
+ Prob = probnode, Cost = utilitynode, Effectiveness = effectivenessnode,
+ Type = typenode
+ )
+
+ return(tabela)
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/summary.simulation.window.Rd
===================================================================
--- pkg/man/summary.simulation.window.Rd (rev 0)
+++ pkg/man/summary.simulation.window.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,1700 @@
+\name{summary.simulation.window}
+\alias{summary.simulation.window}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+summary.simulation.window(Simlist, tempo1 = Sys.time(), tempo2 = Sys.time(), CicloVal, tipo.nodo = " ", digits = 3)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Simlist}{ ~~Describe \code{Simlist} here~~ }
+ \item{tempo1}{ ~~Describe \code{tempo1} here~~ }
+ \item{tempo2}{ ~~Describe \code{tempo2} here~~ }
+ \item{CicloVal}{ ~~Describe \code{CicloVal} here~~ }
+ \item{tipo.nodo}{ ~~Describe \code{tipo.nodo} here~~ }
+ \item{digits}{ ~~Describe \code{digits} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(Simlist, tempo1 = Sys.time(), tempo2 = Sys.time(), CicloVal, tipo.nodo = " ", digits = 3) {
+ require(abind)
+ require(gplots)
+
+ treatments.sim <- names(Simlist)
+
+ windheight <- 300
+ windwidth <- 750
+
+ summarysimulationWindow <- tktoplevel()
+ title <- "ÁrvoRe - Simulação Monte Carlo"
+ tkwm.title(summarysimulationWindow,title)
+
+ frameOverall <- tkwidget(summarysimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+ frameResume <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove")
+ framePanelButton <- tkwidget(frameResume, "labelframe", borderwidth = 0, relief = "groove")
+ framebutton <- tkwidget(summarysimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ pBar <- tkwidget(frameResume, "NoteBook", height = windheight, width = windwidth)
+
+ tkpack(frameOverall, expand = 1, fill = "both") #, side = "left")
+ tkpack(frameResume, expand = 1, fill = "both", side = "top", anchor = "ne")
+ tkpack(framebutton, expand = 1, fill = "x", side = "bottom")
+ tkpack(pBar, expand = 1, fill = "both", side = "left")
+ tkpack(framePanelButton, fill = "both", side = "right") # , anchor = "ne"
+
+ PageNoteBook <- tcl(pBar, "insert", "end", "Page0", "-text", "Nodos")
+
+ timecounter <- 1
+
+ Alltreatmentstable <- data.frame(Treatment = array(,0), Data = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0),Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0), Time = array(,0))
+
+ for (i in treatments.sim) {
+
+ tempo <- tempo2[timecounter] - tempo1[timecounter]
+
+ timecounter <- timecounter + 1
+
+ # Cria uma página para este tratamento -------------------------------------------------
+ position <- which( treatments.sim == i)
+
+ pagetclname <- paste("Page",position, sep = "")
+ pagelabel <- i
+
+ PageNoteBook <- tcl(pBar, "insert", "end", pagetclname, "-text", pagelabel)
+ object.page.name <- paste("PageNoteBook", position, sep = "")
+ assign(object.page.name, PageNoteBook)
+
+ PageNoteBook.Window <- .Tk.newwin(PageNoteBook)
+ object.page.window.name <- paste("PageNoteBook.Window", position, sep = "")
+ assign(object.page.window.name, PageNoteBook.Window)
+
+ frameWindow <- tkwidget(PageNoteBook.Window, "labelframe", borderwidth = 2, relief = "groove", text = "Relatório")
+ # -------------------------------------------------
+
+ frameUpper <- tkframe(frameWindow, relief="groove", borderwidth = 0)
+ frameUpperLeft <- tkwidget(frameUpper, "labelframe", borderwidth = 2, relief = "groove", text = "Custo")
+ frameUpperRight <- tkwidget(frameUpper, "labelframe", borderwidth = 2, relief = "groove", text = "Efetividade")
+ frameLower <- tkframe(frameWindow, relief="groove", borderwidth=2)
+
+ # The node root name
+ node.root.name <- paste("Nodo : ", i, sep = "")
+ node.root.name.label <- tklabel(frameUpper, text = node.root.name)
+ tkgrid(node.root.name.label, sticky = "nw", columnspan = 1)
+
+ # The time of simulation
+ time.text <- paste("Tempo decorrido (segundos) : ", format(round(tempo, digits = digits), nsmall = digits), sep = "")
+ time.sim <- tklabel(frameUpper, text = time.text)
+ tkgrid(time.sim, sticky = "nw", columnspan = 1)
+
+
+ # A Efetividade -------------------------------------------------
+ Mktable <- Simlist[[i]]
+ Data <- Mktable$Effectiveness
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Data,2,sum, na.rm = TRUE)
+ ntreat <- length(Data)
+ statisticsData <- summary(Data)
+
+ meanData <- mean(Data, na.rm = TRUE)
+ varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2)
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ EvarData <- varData
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "Effectiveness", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3, Time = tempo)
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+
+ lableminsize <- tklabel(frameUpperRight,text = paste(rep("_",50),collapse="",sep=""))
+ lableminsize2 <- tklabel(frameUpperRight,text = paste(rep("_",50),collapse="",sep=""))
+# label0 <- tklabel(frameUpperRight,text= "Tempo decorrido (segundos)")
+# label1 <- tklabel(frameUpperRight,text= format(tempo, nsmall = digits) )
+ label2 <- tklabel(frameUpperRight,text= "Valor Médio")
+ label3 <- tklabel(frameUpperRight,text= format(round(meanData, digits = digits), nsmall = digits) )
+ label4 <- tklabel(frameUpperRight,text= "Variância")
+ label5 <- tklabel(frameUpperRight,text= format(round(varData, digits = digits), nsmall = digits) )
+ label6 <- tklabel(frameUpperRight,text= "Desvio Padrão")
+ label7 <- tklabel(frameUpperRight,text= format(round(sdData, digits = digits), nsmall = digits) )
+ label8 <- tklabel(frameUpperRight,text= "Mediana")
+ label9 <- tklabel(frameUpperRight,text= format(round(medianData, digits = digits), nsmall = digits) )
+ label10 <- tklabel(frameUpperRight,text= "Mínimo")
+ label11 <- tklabel(frameUpperRight,text= format(round(minData, digits = digits), nsmall = digits) )
+ label12 <- tklabel(frameUpperRight,text= "Máximo")
+ label13 <- tklabel(frameUpperRight,text= format(round(maxData, digits = digits), nsmall = digits) )
+ label14 <- tklabel(frameUpperRight,text= "1st. Quartil")
+ label15 <- tklabel(frameUpperRight,text= format(round(quartil1, digits = digits), nsmall = digits) )
+ label16 <- tklabel(frameUpperRight,text= "3rd. Quartil")
+ label17 <- tklabel(frameUpperRight,text= format(round(quartil3, digits = digits), nsmall = digits) )
+
+ tkgrid(lableminsize, row = 1, column = 0, columnspan = 2)
+# tkgrid(label0, row = 2, column = 0,sticky="w")
+# tkgrid(label1, row = 2, column = 1,sticky="e")
+ tkgrid(label2, row = 3, column = 0,sticky="w")
+ tkgrid(label3, row = 3, column = 1,sticky="e")
+ tkgrid(label4, row = 4, column = 0,sticky="w")
+ tkgrid(label5, row = 4, column = 1,sticky="e")
+ tkgrid(label6, row = 5, column = 0,sticky="w")
+ tkgrid(label7, row = 5, column = 1,sticky="e")
+ tkgrid(label8, row = 6, column = 0,sticky="w")
+ tkgrid(label9, row = 6, column = 1,sticky="e")
+ tkgrid(label10, row = 7, column = 0,sticky="w")
+ tkgrid(label11, row = 7, column = 1,sticky="e")
+ tkgrid(label12, row = 8, column = 0,sticky="w")
+ tkgrid(label13, row = 8, column = 1,sticky="e")
+ tkgrid(label14, row = 9, column = 0,sticky="w")
+ tkgrid(label15, row = 9, column = 1,sticky="e")
+ tkgrid(label16, row = 10, column = 0,sticky="w")
+ tkgrid(label17, row = 10, column = 1,sticky="e")
+ tkgrid(lableminsize2, row = 11, column = 0, columnspan = 2)
+
+ # O Custo -------------------------------------------------
+ Data <- Mktable$Cost
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Data,2,sum, na.rm = TRUE)
+ ntreat <- length(Data)
+ statisticsData <- summary(Data)
+
+ meanData <- mean(Data, na.rm = TRUE)
+ varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2)
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ CvarData <- varData
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "Cost", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3, Time = tempo)
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+
+ lableminsize <- tklabel(frameUpperLeft,text = paste(rep("_",50),collapse="",sep=""))
+ lableminsize2 <- tklabel(frameUpperLeft,text = paste(rep("_",50),collapse="",sep=""))
+# label0 <- tklabel(frameUpperLeft,text= "Tempo decorrido (segundos)")
+# label1 <- tklabel(frameUpperLeft,text= format(tempo, nsmall = digits) )
+ label2 <- tklabel(frameUpperLeft,text= "Valor Médio")
+ label3 <- tklabel(frameUpperLeft,text= format(round(meanData, digits = digits), nsmall = digits) )
+ label4 <- tklabel(frameUpperLeft,text= "Variância")
+ label5 <- tklabel(frameUpperLeft,text= format(round(varData, digits = digits), nsmall = digits) )
+ label6 <- tklabel(frameUpperLeft,text= "Desvio Padrão")
+ label7 <- tklabel(frameUpperLeft,text= format(round(sdData, digits = digits), nsmall = digits) )
+ label8 <- tklabel(frameUpperLeft,text= "Mediana")
+ label9 <- tklabel(frameUpperLeft,text= format(round(medianData, digits = digits), nsmall = digits) )
+ label10 <- tklabel(frameUpperLeft,text= "Mínimo")
+ label11 <- tklabel(frameUpperLeft,text= format(round(minData, digits = digits), nsmall = digits) )
+ label12 <- tklabel(frameUpperLeft,text= "Máximo")
+ label13 <- tklabel(frameUpperLeft,text= format(round(maxData, digits = digits), nsmall = digits) )
+ label14 <- tklabel(frameUpperLeft,text= "1st. Quartil")
+ label15 <- tklabel(frameUpperLeft,text= format(round(quartil1, digits = digits), nsmall = digits) )
+ label16 <- tklabel(frameUpperLeft,text= "3rd. Quartil")
+ label17 <- tklabel(frameUpperLeft,text= format(round(quartil3, digits = digits), nsmall = digits) )
+
+ tkgrid(lableminsize, row = 1, column = 0, columnspan = 2)
+# tkgrid(label0, row = 2, column = 0,sticky="w")
+# tkgrid(label1, row = 2, column = 1,sticky="e")
+ tkgrid(label2, row = 3, column = 0,sticky="w")
+ tkgrid(label3, row = 3, column = 1,sticky="e")
+ tkgrid(label4, row = 4, column = 0,sticky="w")
+ tkgrid(label5, row = 4, column = 1,sticky="e")
+ tkgrid(label6, row = 5, column = 0,sticky="w")
+ tkgrid(label7, row = 5, column = 1,sticky="e")
+ tkgrid(label8, row = 6, column = 0,sticky="w")
+ tkgrid(label9, row = 6, column = 1,sticky="e")
+ tkgrid(label10, row = 7, column = 0,sticky="w")
+ tkgrid(label11, row = 7, column = 1,sticky="e")
+ tkgrid(label12, row = 8, column = 0,sticky="w")
+ tkgrid(label13, row = 8, column = 1,sticky="e")
+ tkgrid(label14, row = 9, column = 0,sticky="w")
+ tkgrid(label15, row = 9, column = 1,sticky="e")
+ tkgrid(label16, row = 10, column = 0,sticky="w")
+ tkgrid(label17, row = 10, column = 1,sticky="e")
+ tkgrid(lableminsize2, row = 11, column = 0, columnspan = 2)
+
+# eval( parse(text = markov.termination) )
+# eval( parse(text = markov.termination) )
+
+ tkgrid(frameUpperLeft, frameUpperRight, sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ tkpack(frameWindow, expand = 1, fill = "both")
+ tkgrid(PageNoteBook.Window)
+
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Cost,2,sum) / apply(Mktable$Effectiveness,2,sum, na.rm = TRUE)
+
+ statisticsData <- summary(Data)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE, use = "complete.obs")
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = pagelabel, Data = "C/E", Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3, Time = tempo)
+ Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1)
+
+
+ }
+
+ rm(Data, statisticsData, Mktable)
+
+ # Ajusta o Alltreatmentstable
+ rownames(Alltreatmentstable) <- NULL
+ Alltreatmentstable <- as.data.frame(Alltreatmentstable)
+ Alltreatmentstable$Treatment <- as.character(Alltreatmentstable$Treatment)
+ Alltreatmentstable$Data <- as.character(Alltreatmentstable$Data)
+ Alltreatmentstable$Mean <- as.numeric(as.character(Alltreatmentstable$Mean))
+ Alltreatmentstable$Variance <- as.numeric(as.character(Alltreatmentstable$Variance))
+ Alltreatmentstable$Sd <- as.numeric(as.character(Alltreatmentstable$Sd))
+ Alltreatmentstable$Median <- as.numeric(as.character(Alltreatmentstable$Median))
+ Alltreatmentstable$Min <- as.numeric(as.character(Alltreatmentstable$Min))
+ Alltreatmentstable$Max <- as.numeric(as.character(Alltreatmentstable$Max))
+ Alltreatmentstable$Quartil1 <- as.numeric(as.character(Alltreatmentstable$Quartil1))
+ Alltreatmentstable$Quartil2 <- as.numeric(as.character(Alltreatmentstable$Quartil2))
+ Alltreatmentstable$Time <- as.numeric(as.character(Alltreatmentstable$Time))
+ Alltreatmentstable <- Alltreatmentstable[ order(Alltreatmentstable$Data),]
+# print(Alltreatmentstable)
+ assign("Alltreatmentstable", Alltreatmentstable, env = .GlobalEnv)
+
+ # The data to plot
+ AllTreatCost <- Alltreatmentstable[Alltreatmentstable$Data == "Cost",]
+ AllTreatEffectiveness <- Alltreatmentstable[Alltreatmentstable$Data == "Effectiveness",]
+ AllTreatCE <- Alltreatmentstable[Alltreatmentstable$Data == "C/E",]
+
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(AllTreatCost$Treatment)
+ # The treatments names
+ treatments.label.plot <- AllTreatCost$Treatment
+
+ n.treat <- c(0,length(treatments.sim):1,0,length(treatments.sim))
+ for (i in n.treat) {
+ pagetclname <- paste("Page",i, sep="")
+ tcl(pBar,"raise",pagetclname)
+ }
+
+ tcl(pBar,"itemconfigure", "Page0", "-state", "disabled") # Set Page0 page to disabled.
+
+ OnOK <- function()
+ {
+ tkdestroy(summarysimulationWindow)
+ tkwm.deiconify(tt)
+ tkfocus(tt)
+ }
+
+ OnGraph <- function() {
+ selectedpage.number <- tclvalue(tcl(pBar,"raise")) # Retorna a página selecionada
+ selectedpage.number <- as.numeric(substr(selectedpage.number,5,nchar(selectedpage.number)))
+ selected.treatment <- treatments.sim[selectedpage.number]
+ Mktable <- Simlist[[selected.treatment]]
+
+ Cost <- apply(Mktable$Cost,2,sum)
+ Effectiveness <- apply(Mktable$Effectiveness,2,sum)
+
+# OnGraph ---------------------------------------------------------------------------------------------------------------- tkfocus(summarysimulationWindow)
+ graphsimulationWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Gráficos"
+ tkwm.title(graphsimulationWindow, title.window)
+
+ frameOverall <- tkwidget(graphsimulationWindow, "labelframe", borderwidth = 0, relief = "groove")
+ frameResume <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove", text = "Tipos de Gráficos")
+ frameDistribution <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ text = "Distribuição")
+ frameOtherGraphs <- tkwidget(frameOverall, "labelframe", borderwidth = 2, relief = "groove",
+ text = "Custo-Efetividade")
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth = 0)
+
+ OnShowIt <- function(type = "Other", SurvivalData = Mktable$Survival,...) {
+
+ aGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Graphics"
+ tkwm.title(aGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(aGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(aGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # What plot?
+ plot.it.to.image <- function(.Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, SurvivalData = Mktable$Survival,
+ ...) {
+# print(.Filename)
+# print(type)
+# print(img.type)
+
+ if( type == "Distrib.cost") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Cost"
+ hist(Cost, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Distrib.effectiveness") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Efetividade"
+ hist(Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "CE.scatterplot") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "CE Scatterplot"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(Effectiveness,Cost, col = "red", pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Distrib.CER") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Histograma de ", selected.treatment, sep = "")
+ xlabel <- "Razão Custo-Efetividade ($)"
+ hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+ if( type == "Survival.Curve") {
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+# hist(SurvivalData, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+# print(SurvivalData)
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+ # hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- paste("Número de Sobreviventes \n", selected.treatment, sep = "")
+ xlabel <- "Ciclos"
+ # hist(Cost/Effectiveness, main = Graphtitle, xlab = xlabel)
+ barplot(SurvivalData, main = Graphtitle, col = "red", space = c(0,0),
+ xlab = xlabel)
+ dev.off()
+ }
+ }
+ }
+
+
+
+
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(aGraphWindow)
+ tkwm.deiconify(graphsimulationWindow)
+ tkfocus(graphsimulationWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(aGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(.Filename = .Filename, type = type, img.type = ImgFormatselected, img.width = 600, img.height = 600)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+# tkconfigure(Export.but, state = "disabled")
+
+ tkbind(aGraphWindow, "<Return>", OnOK)
+ tkbind(aGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(aGraphWindow)
+ tkfocus(aGraphWindow)
+
+ }
+
+ OnOK <- function() {
+ tkdestroy(graphsimulationWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ OnCancel <- function() {
+ tkdestroy(graphsimulationWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ OnDistrib.cost <- function() {
+ OnShowIt(type = "Distrib.cost")
+ }
+
+ OnDistrib.effectiveness <- function() {
+ OnShowIt(type = "Distrib.effectiveness")
+ }
+
+ OnDistrib.CER <- function() {
+ OnShowIt(type = "Distrib.CER")
+ }
+
+ OnDistrib.incrementals <- function() {
+ OnShowIt(type = "Distrib.incrementals")
+ }
+
+ OnCE <- function() {
+ CEGraphWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Graphics"
+ tkwm.title(CEGraphWindow, title.window)
+
+ frametext <- "Gráfico"
+ frameOverall <- tkwidget(CEGraphWindow, "labelframe", borderwidth = 2, relief = "groove",
+ labelanchor = "n", text = frametext)
+ frameButton <- tkwidget(CEGraphWindow, "labelframe", borderwidth = 0, relief = "groove")
+
+ tkgrid(frameOverall, sticky = "nwe")
+ tkgrid(frameButton, sticky = "swe")
+
+ # Image setings.
+ g.imgHeight <- 600/2
+ g.imgWidth <- 800/2
+
+ # Canvas window configurations
+ C.Height <- min(c(g.imgHeight, 768))
+ C.Width <- min(c(g.imgWidth, 1024))
+ Borderwidth <- 2
+
+ # scrollbar objects
+ fHscroll <- tkscrollbar(frameOverall, orient="horiz", command = function(...)tkxview(fCanvas,...) )
+ fVscroll <- tkscrollbar(frameOverall, command = function(...)tkyview(fCanvas,...) )
+ fCanvas <- tkcanvas(frameOverall, relief = "sunken", borderwidth = Borderwidth,
+ width = C.Width, height = C.Height,
+ xscrollcommand = function(...)tkset(fHscroll,...),
+ yscrollcommand = function(...)tkset(fVscroll,...)
+ )
+
+ # Pack the scroll bars.
+ tkpack(fHscroll, side = "bottom", fill = "x")
+ tkpack(fVscroll, side = "right", fill = "y")
+ # Pack the canvas
+ tkpack(fCanvas, anchor = "center", side = "right", fill = "both", expand = 1)
+
+ # Image file name setings.
+ .Filename <- paste(tempdir(),"\\", "grafico.arvore.png", sep="")
+
+ # The data to plot
+ AllTreatCost <- Alltreatmentstable[Alltreatmentstable$Data == "Cost",]
+ AllTreatEffectiveness <- Alltreatmentstable[Alltreatmentstable$Data == "Effectiveness",]
+ # Initial colors to treatments points
+ treatments.colors.plot <- 1:length(AllTreatCost$Treatment)
+ # The treatments names
+ treatments.label.plot <- AllTreatCost$Treatment
+
+ # What plot?
+ plot.it.to.image <- function(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot,
+ treatments.label.plot,
+ .Filename, img.type = "png", img.quality = 90,
+ img.width = 600, img.height = 600, ...) {
+
+ if (img.type == "png") {
+ png(file=.Filename, width = img.width, height = img.height, bg = "white", restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+ dev.off()
+ } else {
+ if (img.type == "jpg") {
+ jpeg(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, quality = img.quality, bg = "white",
+ res = NA, restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+
+ dev.off()
+ } else {
+ bmp(filename = .Filename, width = img.width, height = img.height,
+ units = "px", pointsize = 12, bg = "white", res = NA,
+ restoreConsole = FALSE)
+ Graphtitle <- "Plano Custo-Efetividade"
+ xlabel <- "Efetividade"
+ ylabel <- "Custo"
+ plot(AllTreatEffectiveness$Mean, AllTreatCost$Mean,
+ col = treatments.colors.plot, pch = "*", main = Graphtitle,
+ xlab = xlabel, ylab = ylabel)
+
+ smartlegend( x="left", y= "top", inset=0, #smartlegend parameters
+ legend = c(treatments.label.plot), #legend parameters
+ fill=c(treatments.colors.plot), #legend parameters
+ bg = "gray")
+
+ dev.off()
+ }
+ }
+ }
+
+ # Default img type
+ img.type <- "png"
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = img.type,
+ img.width = g.imgWidth, img.height = g.imgHeight)
+
+ image1 <- tclVar()
+ tcl("image","create","photo",image1,file=.Filename)
+ tkcreate(fCanvas, "image", g.imgWidth/2, g.imgHeight/2, image = image1, anchor = "center")
+ tkconfigure(fCanvas, scrollregion = c(0,0,g.imgWidth,g.imgHeight))
+
+
+ OnOK <- function() {
+ file.remove(.Filename)
+ tkdestroy(CEGraphWindow)
+ tkwm.deiconify(graphsimulationWindow)
+ tkfocus(graphsimulationWindow)
+ }
+
+ OnExportGraphic <- function(...) {
+ exportImgGraphWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar Imagem"
+ tkwm.title(exportImgGraphWindow,title)
+
+ frameOverall <- tkframe(exportImgGraphWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=0)
+ frameUpperLeft <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameUpperRigth <- tkframe(frameUpper, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, relief="groove", borderwidth=0)
+
+ tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2)
+
+ rbValue <- tclVar("jpg")
+ QualityValue <- tclVar("90")
+
+ rb1 <- tkradiobutton(frameUpper)
+ tkconfigure(rb1,variable=rbValue,value="bmp")
+ tkgrid( tklabel(frameUpperLeft,text="Bitmap .bmp "),rb1, sticky = "ne")
+
+ rb2 <- tkradiobutton(frameUpper)
+ tkconfigure(rb2,variable=rbValue,value="jpg")
+ tkgrid( tklabel(frameUpperLeft,text="Jpeg .jpg "),rb2, sticky = "ne")
+
+ rb3 <- tkradiobutton(frameUpper)
+ tkconfigure(rb3,variable=rbValue,value="png")
+ tkgrid( tklabel(frameUpperLeft,text="Portable network graphics .png "),rb3, sticky = "ne")
+
+ SliderValueLabel <- tklabel(frameUpperRigth, text = as.character(tclvalue(QualityValue)) )
+ sliderlabel <- tklabel(frameUpperRigth, text = "Valor da qualidade de imagem : ")
+ sliderlabel2 <- tklabel(frameUpperRigth,text = "\%")
+ tkgrid(sliderlabel, SliderValueLabel, sliderlabel2)
+ tkconfigure(SliderValueLabel, textvariable = QualityValue)
+ sliderImg <- tkscale(frameUpperRigth, from = 100, to = 1,
+ showvalue = F, variable = QualityValue,
+ resolution = 1, orient = "horizontal")
+ tkgrid(sliderImg,sticky="ew")
+
+ tkgrid(frameUpperLeft, frameUpperRigth,sticky="ns")
+ tkgrid(frameUpper,sticky="ns")
+ tkgrid(frameLower,sticky="ns")
+
+ Onformat <- function() {
+ ansVar <- as.character(tclvalue(rbValue))
+ if (ansVar != "jpg") {
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderlabel, state = "disabled")
+ tkconfigure(sliderlabel2, state = "disabled")
+ tkconfigure(SliderValueLabel, state = "disabled")
+ tkconfigure(sliderImg, state = "disabled")
+ } else {
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderlabel, state = "normal")
+ tkconfigure(sliderlabel2, state = "normal")
+ tkconfigure(SliderValueLabel, state = "normal")
+ tkconfigure(sliderImg, state = "normal")
+ }
+ }
+
+ OnOK <- function(...)
+ {
+ ImgFormatselected <- as.character(tclvalue(rbValue))
+ ImgQualityselected <- as.numeric(as.character(tclvalue(QualityValue)))
+ if (ImgFormatselected == "png") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Portable network graphics Image Files} {.png}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ } else {
+ if (ImgFormatselected == "jpg") {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected,
+ img.quality = ImgQualityselected)
+ }
+ } else {
+ .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Bitmap Image Files} {.bmp}} {{All files} *}"))
+ if (!nchar(.Filename))
+ tkfocus(CEGraphWindow)
+ else {
+ ans <- substr(.Filename,nchar(.Filename)-3,nchar(.Filename))
+ if ( ans != ".bmp" ) .Filename <- paste(.Filename, ".bmp", sep="")
+
+ if (!file.exists(.Filename)) file.remove(.Filename)
+
+ plot.it.to.image(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot,
+ .Filename = .Filename, type = type, img.type = ImgFormatselected)
+ }
+ }
+ }
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(exportImgGraphWindow)
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ tkbind(exportImgGraphWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+ tkbind(exportImgGraphWindow, "<Escape>",OnCancel)
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s")
+
+ tkbind(rb1, "<Enter>",Onformat)
+ tkbind(rb2, "<Enter>",Onformat)
+ tkbind(rb3, "<Enter>",Onformat)
+ tkbind(rb1, "<Leave>",Onformat)
+ tkbind(rb2, "<Leave>",Onformat)
+ tkbind(rb3, "<Leave>",Onformat)
+
+ tkgrid(frameOverall)
+ tkfocus(exportImgGraphWindow)
+# posiciona.janela.no.mouse(exportImgGraphWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <- tkbutton(frameButton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Export.but <- tkbutton(frameButton,text="Exportar...", width=.Width.but, height=.Height.but, command=OnExportGraphic)
+
+ tkgrid(OK.but, Export.but, sticky = "s", padx = 5, pady = 5)
+# tkconfigure(Export.but, state = "disabled")
+
+ tkbind(CEGraphWindow, "<Return>", OnOK)
+ tkbind(CEGraphWindow, "<Escape>", OnCancel)
+
+ tkwm.deiconify(CEGraphWindow)
+ tkfocus(CEGraphWindow)
+
+ }
+
+ OnCE.scatterplot <- function() {
+ OnShowIt(type = "CE.scatterplot")
+ }
+
+ OnAccept.Curve <- function(Alltreatmentstable) {
+ aceptability.sim.window(Alltreatmentstable)
+ }
+
+ OnSurvival.Curve <- function() {
+ SurvivalData <- Mktable$Survival
+ OnShowIt(type = "Survival.Curve", SurvivalData = SurvivalData)
+ }
+
+
+ # Button label
+ label.but1 <- "Custo"
+ label.but2 <- "Efetividade"
+ label.but3 <- "Razão Custo-Efetividade"
+ label.but4 <- "Incrementals"
+ label.but5 <- "Custo-Efetividade"
+ label.but6 <- "Scatterplot C-E"
+ label.but7 <- "Curva de aceitabilidade"
+ label.but8 <- "Curva de sobrevivência"
+
+ .Width.but <- max( c( nchar(label.but1), nchar(label.but2), nchar(label.but3), nchar(label.but4),
+ nchar(label.but5), nchar(label.but6), nchar(label.but7)) )
+ .Height.but <- 1
+
+ # The buttons
+ Distrib.cost.but <- tkbutton(frameDistribution, text = label.but1,
+ width=.Width.but, height=.Height.but, command = OnDistrib.cost)
+ Distrib.effectiveness.but <- tkbutton(frameDistribution,text = label.but2,
+ width=.Width.but, height=.Height.but, command = OnDistrib.effectiveness)
+ Distrib.CER.but <- tkbutton(frameDistribution,text = label.but3,
+ width =.Width.but, height=.Height.but, command = OnDistrib.CER)
+ Distrib.incrementals.but <- tkbutton(frameDistribution, text = label.but4,
+ width=.Width.but, height=.Height.but, command = OnDistrib.incrementals)
+ CE.but <- tkbutton(frameOtherGraphs, text = label.but5,
+ width=.Width.but, height=.Height.but, command = OnCE)
+ CE.scatterplot.but <- tkbutton(frameOtherGraphs,text=label.but6,
+ width=.Width.but, height=.Height.but, command = OnCE.scatterplot)
+ Accept.Curve.but <- tkbutton(frameOtherGraphs,text=label.but7,
+ width=.Width.but, height=.Height.but, command = function() OnAccept.Curve(Alltreatmentstable))
+ Survival.Curve.but <- tkbutton(frameOtherGraphs,text=label.but8,
+ width=.Width.but, height=.Height.but, command = OnSurvival.Curve)
+
+ tkgrid(Distrib.cost.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.effectiveness.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.CER.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Distrib.incrementals.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.scatterplot.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Accept.Curve.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Survival.Curve.but, sticky = "s", padx = 5, pady = 5)
+
+ OK.but <- tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <- tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameDistribution,sticky="nwe")
+ tkgrid(frameOtherGraphs,sticky="nwe")
+ tkgrid(frameResume,sticky="nwe")
+ tkgrid(frameLower, sticky = "s")
+ tkgrid(frameOverall)
+
+ tkbind(graphsimulationWindow, "<Return>", OnOK)
+ tkbind(graphsimulationWindow, "<Escape>", OnCancel)
+
+ tkfocus(graphsimulationWindow)
+# OnGraph ---------------------------------------------------------------------------------------------------------------- tkfocus(summarysimulationWindow)
+
+ }
+
+ OnText <- function() {
+ StatsData <- Alltreatmentstable[ order(Alltreatmentstable$Treatment, Alltreatmentstable$Data),]
+ assign("StatsData", StatsData, .EnvironmentArvoRe)
+
+ Costdata <- subset(StatsData, Data == "Cost")
+ Effectivenessdata <- subset(StatsData, Data == "Effectiveness")
+ CEdata <- subset(StatsData, Data == "C/E")
+
+ statsSWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Estatísticas"
+ tkwm.title(statsSWindow, title.window)
+
+ frameOverall <- tkwidget(statsSWindow, "labelframe", borderwidth = 2, relief = "groove")
+ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0)
+
+ OnNM <- function() {
+ WTPVal <- as.integer(tclvalue(WTPvar))
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+ Data <- DataEffectiveness * WTPVal - DataCost
+ NMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ namesvariables <- c(".Cost", ".Effectiveness", ".NMB")
+ names(NMBtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+ Data <- DataEffectiveness * WTPVal - DataCost
+
+ newNMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ names(newNMBtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ NMBtable <- abind(NMBtable, newNMBtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ NMBtable <- abind(Trial, NMBtable, along=2)
+ names(NMBtable) <- c("Trial", names(NMBtable))
+
+ tituloNMB <- "Estatísticas - Net Monetary Benefits"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnNH <- function() {
+ WTPVal <- as.integer(tclvalue(WTPvar))
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+ Data <- DataEffectiveness * WTPVal - DataCost
+
+ NMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ namesvariables <- c(".Cost", ".Effectiveness", ".NMB")
+ names(NMBtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+ Data <- DataEffectiveness * WTPVal - DataCost
+
+ newNMBtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ NMB = Data)
+ names(newNMBtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ NMBtable <- abind(NMBtable, newNMBtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ NMBtable <- abind(Trial, NMBtable, along=2)
+ names(NMBtable) <- c("Trial", names(NMBtable))
+
+ tituloNMB <- "Estatísticas - Net Health Benefits"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnCE <- function() {
+
+ selected.treatment <- treatments.sim[1]
+ Mktable <- Simlist[[selected.treatment]]
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+
+ CEtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ CE = DataCost / DataEffectiveness)
+ namesvariables <- c(".Cost", ".Effectiveness", ".CE")
+ names(CEtable) <- paste(selected.treatment,namesvariables,sep="")
+
+ if (length(treatments.sim) > 1) {
+ for (i in 2:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The CE -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ DataCost <- apply(Mktable$Cost,2,sum)
+ DataEffectiveness <- apply(Mktable$Effectiveness,2,sum)
+
+ newCEtable <- data.frame( Cost = DataCost,
+ Effectiveness = DataEffectiveness,
+ CE = DataCost / DataEffectiveness)
+ names(newCEtable) <- paste(selected.treatment,namesvariables,sep="")
+ # Guarda as informações importantes
+ CEtable <- abind(CEtable, newCEtable, along=2)
+
+ }
+ }
+ Trial <- 1:length(DataCost)
+ CEtable <- abind(Trial, CEtable, along=2)
+ names(CEtable) <- c("Trial", names(CEtable))
+
+ tituloCE <- "Estatísticas - Análise de Custo-Efetividade"
+ CEtable <- as.matrix(CEtable)
+
+ displayInTable(CEtable, title = tituloCE, height=min(10,dim(CEtable)[1]), width= min(10,dim(CEtable)[2]),
+ nrow=dim(CEtable)[1],ncol=dim(CEtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ .Width.but <- 18
+ .Height.but <- 1
+
+ NM.but <-tkbutton(frameOverall,text="Net monetary benefit", width=.Width.but, height=.Height.but, command=OnNM)
+ NH.but <-tkbutton(frameOverall,text="Net health benefit", width=.Width.but, height=.Height.but, command=OnNH)
+ CE.but <-tkbutton(frameOverall,text="Custo-Efetividade", width=.Width.but, height=.Height.but, command=OnCE)
+
+ tkgrid(NM.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(NH.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(frameOverall,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(frameOverall,text="Valor do willingness-to-pay (WTP)"),
+ row = 4, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, row = 5, column = 0, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(frameOverall,text=" "),
+ row = 6, column = 0, columnspan = 2, sticky = "n")
+
+
+ tkgrid( frameOverall, sticky = "n", columnspan = 2, padx = 5, pady = 5)
+ tkgrid( frameButtons, sticky = "s")
+
+ OnOK <- function() {
+ tkdestroy(statsSWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ tkbind(statsSWindow, "<Return>",OnOK)
+ tkbind(statsSWindow, "<Escape>",OnOK)
+
+ OK.but <-tkbutton(frameButtons,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+# Cancel.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+
+ tkgrid(OK.but, sticky = "s", columnspan = 2, padx = 5, pady = 5)
+
+ }
+
+ OnExport <- function() {
+ filetypeWindow <- tktoplevel()
+ title <- "ÁrvoRe - Exportar"
+ tkwm.title(filetypeWindow,title)
+
+ frameOverall <- tkframe(filetypeWindow)
+ frameUpper <- tkframe(frameOverall, relief="groove", borderwidth=2)
+ frameLower <- tkframe(frameOverall, borderwidth=2)
+
+ tkgrid(tklabel(frameUpper,text="Selecione o tipo de arquivo:"))
+ filetypes <- c("CSV (separado por vírgulas)","TXT (texto separado por tabulações)","Todos arquivos")
+ fileextensions <- c(".csv", ".txt", " ")
+
+ widthcombo <- max( nchar(filetypes) )
+
+ comboBox <- tkwidget(frameUpper,"ComboBox", width = widthcombo, editable = FALSE, values = filetypes)
+ tkgrid(comboBox)
+
+ OnOK <- function() {
+ filetypeChoice <- filetypes[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ fileextChoice <- fileextensions[as.numeric(tclvalue(tcl(comboBox,"getvalue")))+1]
+ tkdestroy(filetypeWindow)
+ filetypes <- paste("{{ ", filetypeChoice, "}", " {", fileextChoice, "}}", sep = "")
+ fileName <- tclvalue(tkgetSaveFile(filetypes=filetypes))
+
+ if (!nchar(fileName))
+ tkfocus(summarysimulationWindow)
+ else {
+ selectedpage.number <- tclvalue(tcl(pBar,"raise")) # Retorna a página selecionada
+ selectedpage.number <- as.numeric(substr(selectedpage.number,5,nchar(selectedpage.number)))
+ selected.treatment <- treatments.sim[selectedpage.number]
+ Mktable <- Simlist[[selected.treatment]]
+
+ if (tipo.nodo[selectedpage.number] == "C") {
+ ResumeSim <- data.frame(Cost = apply(Mktable$Cost,2,sum),
+ Effectiveness = apply(Mktable$Effectiveness,2,sum))
+ ResumeSim <- data.frame(Trial = 0:(dim(ResumeSim)[1] - 1), ResumeSim)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ } else {
+ if (tipo.nodo[selectedpage.number] == "M") {
+
+ # Summary Coort
+ ResumeSim <- data.frame(Cost = apply(Mktable$Cost,2,sum),
+ Effectiveness = apply(Mktable$Effectiveness,2,sum))
+ ResumeSim <- data.frame(Individual = 1:(dim(ResumeSim)[1]), ResumeSim)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ } else {
+ fileName <- paste(fileName, ".csv", sep = "")
+ write.csv2(ResumeSim, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+
+ # Full detail
+ Cycle <- 0:(dim(Mktable$Path)[1] - 1)
+ ResumeSim.Cost <- data.frame( Cycle, Mktable$Cost )
+ ResumeSim.Effectiveness <- data.frame( Cycle, Mktable$Effectiveness )
+ ResumeSim.Path <- data.frame( Cycle, Mktable$Path )
+
+# print(fileName)
+
+ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName))
+ if ( substr(fileName,nchar(fileName)-3,nchar(fileName)-3) == "." ) {
+ ans.root.file.name <- substr(fileName,1,nchar(fileName)-4)
+ } else {
+ ans.root.file.name <- fileName
+ }
+
+ if ( fileextChoice == ".csv" ) {
+ if (ans == ".csv") {
+# print("Estou salvando")
+ fileName <- paste(ans.root.file.name," Cost", ans, sep = "")
+ write.csv2(ResumeSim.Cost, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name," Effectiveness", ans, sep = "")
+ write.csv2(ResumeSim.Effectiveness, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name," Path", ans, sep = "")
+ write.csv2(ResumeSim.Path, file = fileName, row.names = FALSE)
+ } else {
+# print("Estou salvando")
+ fileName <- paste(ans.root.file.name, " Cost", ".csv", sep = "")
+ write.csv2(ResumeSim.Cost, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name, " Effectiveness", ".csv", sep = "")
+ write.csv2(ResumeSim.Effectiveness, file = fileName, row.names = FALSE)
+ fileName <- paste(ans.root.file.name, " Path", ".csv", sep = "")
+ write.csv2(ResumeSim.Path, file = fileName, row.names = FALSE)
+ }
+ }
+ if ( fileextChoice == ".txt" ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+ if ( fileextChoice == " " ) {
+ if (ans == ".txt") {
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ } else {
+ fileName <- paste(fileName, ".txt", sep = "")
+ write.table(ResumeSim, file = fileName, sep = "\t")
+ }
+ }
+
+ } else {
+ cat("Aviso: não é possível exportar resultados para nodo Terminal")
+ }
+ }
+
+ tkfocus(summarysimulationWindow)
+ }
+
+ }
+
+ OnCancel <- function() {
+ tkdestroy(filetypeWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ .Width.but <- 10
+ .Height.but <- 1
+
+ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(frameUpper,sticky="nwe")
+ tkgrid(frameLower,sticky="nwe")
+ tkgrid(frameOverall)
+
+ tkbind(filetypeWindow, "<Return>",OnOK)
+ tkbind(filetypeWindow, "<Escape>",OnOK)
+
+ tkfocus(filetypeWindow)
+ }
+
+ OnStatsRep <- function() {
+
+
+ StatsData <- Alltreatmentstable[ order(Alltreatmentstable$Treatment, Alltreatmentstable$Data),]
+ assign("StatsData", StatsData, .EnvironmentArvoRe)
+
+ Costdata <- subset(StatsData, Data == "Cost")
+ Effectivenessdata <- subset(StatsData, Data == "Effectiveness")
+ CEdata <- subset(StatsData, Data == "C/E")
+
+
+# print(StatsData)
+
+ statsSWindow <- tktoplevel()
+ title.window <- "ÁrvoRe - MC Simulação - Estatísticas"
+ tkwm.title(statsSWindow, title.window)
+
+ frameOverall <- tkwidget(statsSWindow, "labelframe", borderwidth = 2, relief = "groove")
+ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0)
+
+ OnNM <- function() {
+ WTPVal <- as.integer(tclvalue(WTPvar))
+
+ NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0), Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0))
+
+ for (i in 1:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NMB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Effectiveness,2,sum) * WTPVal - apply(Mktable$Cost,2,sum)
+
+ statisticsData <- summary(Data)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE, use = "complete.obs")
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = selected.treatment, Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3)
+ NMBtable <- abind(NMBtable, line.data.summary, along=1)
+ }
+
+ tituloNMB <- "Estatísticas - Net Monetary Benefits"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnNH <- function() {
+ WTPVal <- as.integer(tclvalue(WTPvar))
+
+ NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0),
+ Variance = array(,0), Sd = array(,0), Median = array(,0),
+ Min = array(,0), Max = array(,0),
+ Quartil1 = array(,0), Quartil2 = array(,0))
+
+ for (i in 1:length(treatments.sim) ) {
+ selected.treatment <- treatments.sim[i]
+ Mktable <- Simlist[[selected.treatment]]
+
+ # The NHB -----------------------------------------------------------------------
+ # Remover esta linha se sumarizar saídas de funções de simulação
+ Data <- apply(Mktable$Effectiveness,2,sum) * WTPVal - apply(Mktable$Cost,2,sum)
+
+ statisticsData <- summary(Data)
+
+ meanData <- statisticsData[4]
+ varData <- var(Data, na.rm = TRUE, use = "complete.obs")
+ sdData <- sqrt(varData)
+ medianData <- statisticsData[3]
+ minData <- statisticsData[1]
+ maxData <- statisticsData[6]
+ quartil1 <- statisticsData[2]
+ quartil3 <- statisticsData[5]
+
+ # Guarda as informações importantes
+ line.data.summary <- data.frame(Treatment = selected.treatment, Mean = meanData,
+ Variance = varData, Sd = sdData, Median = medianData,
+ Min = minData, Max = maxData,
+ Quartil1 = quartil1, Quartil2 = quartil3)
+ NMBtable <- abind(NMBtable, line.data.summary, along=1)
+ }
+
+ tituloNMB <- "Estatísticas - Net Monetary Benefits"
+ NMBtable <- as.matrix(NMBtable)
+
+ displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]),
+ nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+
+ }
+
+ OnCE <- function() {
+# ResumeData <- as.data.frame( t(StatsData[,2:dim(StatsData)[2]]) )
+# names(ResumeData) <- StatsData[,1]
+# ResumeData <- as.matrix(ResumeData)
+
+ tituloCE <- "Estatísticas - Análise de Custo-Efetividade"
+ StatsData <- as.matrix(StatsData)
+
+ displayInTable(StatsData, title = tituloCE, height=min(10,dim(StatsData)[1]), width= min(10,dim(StatsData)[2]),
+ nrow=dim(StatsData)[1],ncol=dim(StatsData)[2],
+ titlerows = FALSE, titlecols = TRUE, editable = FALSE,
+ returntt = FALSE)
+ }
+
+ OnICER <- function(Alltreatmentstable) {
+ icer.sim.window(Alltreatmentstable)
+ }
+
+ OnINB <- function(Alltreatmentstable) {
+ inb.sim.window(Alltreatmentstable)
+ }
+
+ .Width.but <- 40
+ .Height.but <- 1
+
+ NM.but <-tkbutton(frameOverall,text="Net monetary benefit", width=.Width.but, height=.Height.but, command=OnNM)
+ NH.but <-tkbutton(frameOverall,text="Net health benefit", width=.Width.but, height=.Height.but, command=OnNH)
+ CE.but <-tkbutton(frameOverall,text="Custo-Efetividade", width=.Width.but, height=.Height.but, command=OnCE)
+ ICER.but <-tkbutton(frameOverall,text="Razão adicional de C-E (ICER)", width=.Width.but, height=.Height.but,
+ command= function() OnICER(StatsData))
+ INB.but <-tkbutton(frameOverall,text="Incremento da rede de benfícios (INB)", width=.Width.but,
+ height=.Height.but, command= function() OnINB(StatsData))
+
+
+ tkgrid(NM.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(NH.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(CE.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(ICER.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(INB.but, sticky = "s", padx = 5, pady = 5)
+
+ WTPvar <- tclVar(0.1)
+
+ WTPValue <- tkentry(frameOverall,width="20",textvariable=WTPvar)
+ tkgrid(tklabel(frameOverall,text="Valor do willingness-to-pay (WTP)"),
+ columnspan = 2, sticky = "n")
+ tkgrid(WTPValue, columnspan = 2, sticky = "n")
+ tkgrid(tklabel(frameOverall,text=" "),
+ columnspan = 2, sticky = "n")
+
+
+ tkgrid( frameOverall, sticky = "n", columnspan = 2, padx = 5, pady = 5)
+ tkgrid( frameButtons, sticky = "s")
+
+ OnOK <- function() {
+ tkdestroy(statsSWindow)
+ tkfocus(summarysimulationWindow)
+ }
+
+ tkbind(statsSWindow, "<Return>",OnOK)
+ tkbind(statsSWindow, "<Escape>",OnOK)
+
+ OK.but <-tkbutton(frameButtons,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+# Cancel.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+
+ tkgrid(OK.but, sticky = "s", columnspan = 2, padx = 5, pady = 5)
+
+ }
+
+ .Width.but <- 18
+ .Height.but <- 1
+
+ OK.but <-tkbutton(framebutton,text="OK", width=.Width.but, height=.Height.but, command=OnOK)
+ StatsRep.but <-tkbutton(framePanelButton,text="Estatísticas", width=.Width.but, height=.Height.but,command=OnStatsRep)
+ Graph.but <-tkbutton(framePanelButton,text="Gráficos", width=.Width.but, height=.Height.but,command=OnGraph)
+ TextRep.but <-tkbutton(framePanelButton,text="Relatório Texto", width=.Width.but, height=.Height.but,command=OnText)
+ Export.but <-tkbutton(framePanelButton,text="Exportar Relatório", width=.Width.but, height=.Height.but,command=OnExport)
+
+ tkbind(summarysimulationWindow, "<Return>",OnOK)
+ tkbind(summarysimulationWindow, "<Escape>",OnOK)
+
+
+ tkgrid(StatsRep.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Graph.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(TextRep.but, sticky = "s", padx = 5, pady = 5)
+ tkgrid(Export.but, sticky = "s", padx = 5, pady = 5)
+
+ tkgrid(OK.but, sticky = "s", padx = 5, pady = 5)
+
+# posiciona.janela.centro(tt, summarysimulationWindow)
+
+ tkfocus(summarysimulationWindow)
+
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/terminal.markov.coort.table.Rd
===================================================================
--- pkg/man/terminal.markov.coort.table.Rd (rev 0)
+++ pkg/man/terminal.markov.coort.table.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,51 @@
+\name{terminal.markov.coort.table}
+\alias{terminal.markov.coort.table}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+terminal.markov.coort.table(TheTree, trials = 2)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+ \item{trials}{ ~~Describe \code{trials} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree, trials = 2) {
+ # cria a tabela de resposta
+ Coorte.Ind <- matrix("1",1,trials) # Matriz com cada individuo
+ Coorte.Cost <- matrix(TheTree$Payoff1,1,trials) # Matriz com custo de cada individuo
+ Coorte.Effec <- matrix(TheTree$Payoff2,1,trials) # Matriz com a efetividade de cada individuo
+ ans <- list(Path = Coorte.Ind, Cost = Coorte.Cost, Effectiveness = Coorte.Effec)
+ return(ans) # And return the result
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/theTreeTkArvore.Rd
===================================================================
--- pkg/man/theTreeTkArvore.Rd (rev 0)
+++ pkg/man/theTreeTkArvore.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,90 @@
+\name{theTreeTkArvore}
+\alias{theTreeTkArvore}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+theTreeTkArvore(TheTree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{TheTree}{ ~~Describe \code{TheTree} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(TheTree) {
+
+ num.lin <- dim(TheTree)[1]
+ num.levels <- max(TheTree$Level)
+
+ for (i in 1:length(.libPaths())) {
+ SubDataSet <- subset(TheTree, Level == 1)
+ osnodos <- SubDataSet$Node.N
+ osnodosnomes <- SubDataSet$Node.name
+ osnodostipos <- SubDataSet$Type
+ osnodos <- paste(i,".",osnodos,sep="")
+
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/", osnodostipos,".png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ tkinsert(treeWidget,"end","root","1.1",text=osnodosnomes, image = icn)
+ } else {
+ tkinsert(treeWidget,"end","root","1.1",text=osnodosnomes)
+ }
+ }
+
+ if (num.lin > 1) {
+ for (i in 2:num.levels) {
+ SubDataSet <- subset(TheTree, Level == i)
+ osnodos <- SubDataSet$Node.N
+ paisnodos <- SubDataSet$Father
+ osnodosnomes <- SubDataSet$Node.name
+ osnodostipos <- SubDataSet$Type
+# cat("DEBUG : Criei os nodos \n ", osnodos, " cujos pais são ", paisnodos, "\n")
+
+ osnodos <- paste(i,".",osnodos,sep="")
+ paisnodos <- paste((i-1),".",paisnodos,sep="")
+
+ for (j in 1:length(osnodos)) {
+ tipofilename <- osnodostipos[j]
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/", tipofilename,".png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ tkinsert(treeWidget,"end",paisnodos[j],osnodos[j],text=osnodosnomes[j], image = icn)
+ } else {
+ tkinsert(treeWidget,"end",paisnodos[j],osnodos[j],text=osnodosnomes[j])
+ }
+ }
+ }
+ }
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/typenodewindows.Rd
===================================================================
--- pkg/man/typenodewindows.Rd (rev 0)
+++ pkg/man/typenodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,201 @@
+\name{typenodewindows}
+\alias{typenodewindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+typenodewindows()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+ # A janela Tk
+ typenodeWindow <- tktoplevel(height = 200, width = 150)
+ title <- "ÁrvoRe - Tipo Nodo"
+ tkwm.title(typenodeWindow,title)
+ tkgrid(tklabel(typenodeWindow,text="Selecione o tipo do nodo"), column = 0, row = 0, sticky = "n")
+
+ Frame1 <- tkframe(typenodeWindow, height = 200, width = 150,
+ borderwidth = 2, relief = "groove")
+ Frame2 <- tkframe(typenodeWindow, height = 200, width = 150,
+ borderwidth = 0, relief = "groove")
+
+ tkgrid(Frame1, sticky = "n")
+ tkgrid(Frame2, sticky = "s")
+
+ # Type Chance
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/C.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb1 <- tkradiobutton(Frame1)
+ rbValue <- tclVar("C")
+ tkconfigure(rb1,variable=rbValue,value="C")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Chance "),rb1, sticky = "ne")
+
+ } else {
+ rb1 <- tkradiobutton(Frame1)
+ rbValue <- tclVar("C")
+ tkconfigure(rb1,variable=rbValue,value="C")
+ tkgrid( tklabel(Frame1,text="Chance "),rb1, sticky = "ne")
+ }
+ }
+
+ # Type Decision
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/D.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb2 <- tkradiobutton(Frame1)
+ tkconfigure(rb2, variable=rbValue, value="D")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Decision "),rb2, sticky = "ne")
+
+ } else {
+ rb2 <- tkradiobutton(Frame1)
+ tkconfigure(rb2,variable=rbValue,value="D")
+ tkgrid( rb2, column = 0, row = 2, sticky = "nw")
+ tkgrid( tklabel(Frame1,text="Decision "),rb2, sticky = "ne")
+ }
+ }
+
+ # Type Logic
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/L.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb3 <- tkradiobutton(Frame1)
+ tkconfigure(rb3,variable=rbValue,value="L")
+ rb3text <- tklabel(Frame1,text="Logic ")
+ tkgrid( tklabel(Frame1,image=icn), rb3text,
+ rb3, sticky = "ne")
+ } else {
+ rb3 <- tkradiobutton(Frame1)
+ tkconfigure(rb3,variable=rbValue,value="L")
+ rb3text <- tklabel(Frame1,text="Logic ")
+ tkgrid( rb3text ,rb3, sticky = "ne")
+ }
+ }
+
+ tkconfigure(rb3, state = "disabled")
+ tkconfigure(rb3text, state = "disabled")
+
+ # Type Markov
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/M.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb4 <- tkradiobutton(Frame1)
+ tkconfigure(rb4,variable=rbValue,value="M")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Markov "),rb4, sticky = "ne")
+ } else {
+ rb4 <- tkradiobutton(Frame1)
+ tkconfigure(rb4,variable=rbValue,value="M")
+ tkgrid( tklabel(Frame1,text="Markov ") ,rb4, sticky = "ne")
+ }
+ }
+
+ # Type Terminal
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/T.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb5 <- tkradiobutton(Frame1)
+ tkconfigure(rb5,variable=rbValue,value="T")
+ tkgrid( tklabel(Frame1,image=icn),
+ tklabel(Frame1,text="Terminal "),rb5, sticky = "ne")
+ } else {
+ rb5 <- tkradiobutton(Frame1)
+ tkconfigure(rb5,variable=rbValue,value="T")
+ tkgrid( tklabel(Frame1,text="Terminal ") ,rb5, sticky = "ne")
+ }
+ }
+
+ # Type Label
+ for (i in 1:length(.libPaths())) {
+ icon.but <- file.path(paste(.libPaths()[i],"/arvoRe/icons/X.png",sep=""))
+ if (file.exists(icon.but)) {
+ icn <- tkimage.create("photo", file=icon.but)
+ rb6 <- tkradiobutton(Frame1)
+ tkconfigure(rb6,variable=rbValue,value="X")
+ rb6text <- tklabel(Frame1,text="Label ")
+ tkgrid( tklabel(Frame1,image=icn), rb6text, rb6, sticky = "ne")
+ } else {
+ rb6 <- tkradiobutton(Frame1)
+ tkconfigure(rb6,variable=rbValue,value="X")
+ rb6text <- tklabel(Frame1,text="Label ")
+ tkgrid( rb6text ,rb6, sticky = "ne")
+ }
+ }
+
+ tkconfigure(rb6, state = "disabled")
+ tkconfigure(rb6text, state = "disabled")
+
+ tkfocus(typenodeWindow)
+
+ OnOK <- function()
+ {
+ nodo.type <- as.character(tclvalue(rbValue))
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ settypenode(TheTree, column = column, node.number = node.number, nodo.type = nodo.type, .EnvironmentArvoRe)
+ refreshF5()
+ tkdestroy(typenodeWindow)
+ tkfocus(tt)
+ }
+
+ OnCancel <- function()
+ {
+ tkdestroy(typenodeWindow)
+ tkfocus(tt)
+ }
+
+ OK.but <-tkbutton(Frame2,text=" OK ",command=OnOK)
+ tkbind(typenodeWindow, "<Return>",OnOK)
+ Cancel.but <-tkbutton(Frame2,text=" Cancel ",command=OnCancel)
+ tkbind(typenodeWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(typenodeWindow, 150, 200)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/utilitywindows.Rd
===================================================================
--- pkg/man/utilitywindows.Rd (rev 0)
+++ pkg/man/utilitywindows.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,110 @@
+\name{utilitywindows}
+\alias{utilitywindows}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+utilitywindows()
+}
+%- maybe also 'usage' for other objects documented here.
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function() {
+ nodeSec <- nodoselecionado()
+ if ( nodeSec[1] == " ") {
+ msg <- paste("Nenhum nodo selecionado. Selecione um nodo da árvore e tente novamente.")
+ tkmessageBox(message = msg, icon="warning", title = "ÁrvoRe - AVISO")
+ tkfocus(tt)
+ } else {
+ utilityWindow <- tktoplevel()
+ title <- "ÁrvoRe - Payoffs Nodo"
+ tkwm.title(utilityWindow,title)
+
+ node.number <- as.numeric(nodeSec[3])
+ column <- as.numeric(nodeSec[2])
+ position <- intersect(which((TheTree$Level == column)),which(TheTree$Node.N == node.number))
+
+ utilityvar <- tclVar(TheTree$Payoff1[position])
+ effectivenessvar <- tclVar(TheTree$Payoff2[position])
+
+ entry.Value <- tkentry(utilityWindow,width="20",textvariable=utilityvar)
+ tkgrid(tklabel(utilityWindow,text="Valor do custo"))
+ tkgrid(entry.Value)
+
+ entry.Value.effectiveness <- tkentry(utilityWindow,width="20",textvariable=effectivenessvar)
+ label.entry.Value.effect <- tklabel(utilityWindow,text="Valor da efetividade")
+ tkgrid(label.entry.Value.effect)
+ tkgrid(entry.Value.effectiveness)
+
+ if (.modeltypeArvore == "SD") {
+ tkconfigure(entry.Value.effectiveness, state = "disabled")
+ tkconfigure(label.entry.Value.effect, state = "disabled")
+ }
+
+ OnOK <- function()
+ {
+ utilityVal <- as.numeric(tclvalue(utilityvar))
+ effectivenessVal <- as.numeric(tclvalue(effectivenessvar))
+
+ if ( (is.numeric(utilityVal)) && (!is.na(utilityVal)) &&
+ (is.numeric(effectivenessVal)) && (!is.na(effectivenessVal)) ) {
+ tkdestroy(utilityWindow)
+ safedofunction(TheTree, .EnvironmentArvoRe, .modeltypeArvore)
+ setutility(TheTree, nodeSec[2], nodeSec[3], utilityVal, .EnvironmentArvoRe)
+ seteffectiveness(TheTree, nodeSec[2], nodeSec[3], effectivenessVal, .EnvironmentArvoRe)
+ refreshF5()
+ tkfocus(tt)
+ } else {
+ msg <- paste("Este não é um valor de utilidade válido '",utilityVal, "'")
+ tkmessageBox(message=msg)
+ tkfocus(utilityWindow)
+ }
+ }
+ OK.but <-tkbutton(utilityWindow,text=" OK ",command=OnOK)
+
+ OnCancel <- function()
+ {
+ tkdestroy(utilityWindow)
+ tkfocus(tt)
+ }
+
+ Cancel.but <-tkbutton(utilityWindow,text=" Cancel ",command=OnCancel)
+
+ tkbind(entry.Value, "<Return>",OnOK)
+ tkbind(entry.Value.effectiveness, "<Return>",OnOK)
+ tkbind(utilityWindow, "<Escape>",OnCancel)
+
+ tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5)
+
+ posiciona.janela.no.mouse(utilityWindow, 200, 130)
+ tkfocus(utilityWindow)
+ }
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/zoom.in.but.Rd
===================================================================
--- pkg/man/zoom.in.but.Rd (rev 0)
+++ pkg/man/zoom.in.but.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,59 @@
+\name{zoom.in.but}
+\alias{zoom.in.but}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+zoom.in.but(imgHeight)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{imgHeight}{ ~~Describe \code{imgHeight} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(imgHeight) {
+ if (imgHeight < 8000) {
+ imgHeight <- round(imgHeight * 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ } else {
+ msg <- paste("Este é um tamanho de imagem consideravelmente grande. Deseja realmente ampliar?")
+ ans <- tkmessageBox(message = msg, icon = "question", type = "yesnocancel", default = "no")
+ ans <- as.character(tclvalue(ans))
+ if ( ans == "yes" ) {
+ imgHeight <- round(imgHeight * 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ }
+ tkfocus(tt)
+ }
+ set.zoom.image.tree(imgHeight, imgWidth)
+ refreshF5()
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
Added: pkg/man/zoom.out.but.Rd
===================================================================
--- pkg/man/zoom.out.but.Rd (rev 0)
+++ pkg/man/zoom.out.but.Rd 2008-08-08 04:36:00 UTC (rev 2)
@@ -0,0 +1,50 @@
+\name{zoom.out.but}
+\alias{zoom.out.but}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ ~~function to do ... ~~ }
+\description{
+ ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+zoom.out.but(imgHeight)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{imgHeight}{ ~~Describe \code{imgHeight} here~~ }
+}
+\details{
+ ~~ If necessary, more details than the description above ~~
+}
+\value{
+ ~Describe the value returned
+ If it is a LIST, use
+ \item{comp1 }{Description of 'comp1'}
+ \item{comp2 }{Description of 'comp2'}
+ ...
+}
+\references{ ~put references to the literature/web site here ~ }
+\author{ ~~who you are~~ }
+\note{ ~~further notes~~
+
+ ~Make other sections like Warning with \section{Warning }{....} ~
+}
+\seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ }
+\examples{
+##---- Should be DIRECTLY executable !! ----
+##-- ==> Define data, use random,
+##-- or do help(data=index) for the standard data sets.
+
+## The function is currently defined as
+function(imgHeight) {
+ if (imgHeight >= 320) {
+ imgHeight <- round(imgHeight / 1.1, digits = 0)
+ imgWidth <- round((4/3) * imgHeight, digits = 0)
+ set.zoom.image.tree(imgHeight, imgWidth)
+ }
+ refreshF5()
+ }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
More information about the Arvore-commits
mailing list