From noreply at r-forge.r-project.org Fri Aug 8 06:36:01 2008 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 08 Aug 2008 04:36:01 -0000 Subject: [Arvore-commits] r2 - in pkg: . R icons man Message-ID: <20080808043601.368B09C866@r-forge.r-project.org> 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 and Suzi A. Camey +Maintainer: Isaias V. Prestes +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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(CEGraphWindow, "", 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(ACGraphWindow, "", 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, "",OnOK) + tkbind(ACsimtableWindow, "",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, "",OnOK) + tkbind(CEtableWindow, "",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, "",OnOK) + tkbind(ProbabilidadeVar, "",OnOK) + tkbind(UtilityEntryWidget, "",OnOK) + tkbind(EffectivenessEntryWidget, "",OnOK) + tkbind(NotasVar, "",OnOK) + + OnCancel <- function() + { + tkdestroy(addnodeWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(addnodeWindow,text=" Cancelar ",command=OnCancel) + tkbind(addnodeWindow, "",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, "",sair) + tkbind(tt, "",new.file.bot) + tkbind(tt, "",load.file.arv) + tkbind(tt, "",save.file.arv) + tkbind(tt, "",save.file.arv) + tkbind(tt, "",naoimplementado) + tkbind(tt, "",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, "",OnOK) + Cancel.but <-tkbutton(destinyWindow,text=" Cancelar ",command=OnCancel) + tkbind(destinyWindow, "",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, "",OnOK) + tkbind(Individuos.Value, "",OnOK) + tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOK) + tkbind(Individuos.Value, "",OnOK) + tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOK) + tkbind(Trialss.Value, "",OnOK) +# tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOkAdd) + tkbind(addvariableWindow, "",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, "",OnOkAdd) + tkbind(addvariableWindow, "",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, "",OnOK) + tkbind(variableWindow, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOK) + tkbind(displayInTableWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportgraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(CEsimtableWindow, "",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, "",OnOK) + tkbind(INBsimtableWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOKINB) + tkbind(plotINBtableWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(markovnodeWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancelar", command=OnCancel) + + tkbind(markovnodeWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(nodenameWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(nodenameWindow, text=" Cancelar ", command=OnCancel) + tkbind(nodenameWindow, "",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, "", OnOK) + + OnCancel <- function() + { + tkdestroy(notesWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(notesWindow, text=" Cancelar ", command=OnCancel) + tkbind(notesWindow, "", 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(aGraphWindow, "", 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, "", OnOK) + tkbind(graphsimulationWindow, "", 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(plotCEtableWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(probWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(probWindow,text=" Cancelar ",command=OnCancel) + tkbind(probWindow, "",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, "",OnOK) + tkbind(propertiesWindow, "",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, "",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, "",OnOK) + tkbind(statsSWindow, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOK) + tkbind(statsSWindow, "",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, "",OnOK) + tkbind(summarysimulationWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(Frame2,text=" Cancelar ",command=OnCancel) + tkbind(typenodeWindow, "",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, "",OnOK) + tkbind(entry.Value.effectiveness, "",OnOK) + tkbind(utilityWindow, "",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, "", OnOK) + tkbind(win.main.resWindow, "", 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 +~~ 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[:-package]{}} ~~ +} +\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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(ACGraphWindow, "", 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, "",OnOK) + tkbind(ACsimtableWindow, "",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, "",OnOK) + tkbind(CEtableWindow, "",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, "",OnOK) + tkbind(ProbabilidadeVar, "",OnOK) + tkbind(UtilityEntryWidget, "",OnOK) + tkbind(EffectivenessEntryWidget, "",OnOK) + tkbind(NotasVar, "",OnOK) + + OnCancel <- function() + { + tkdestroy(addnodeWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(addnodeWindow,text=" Cancel ",command=OnCancel) + tkbind(addnodeWindow, "",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, "",sair) + tkbind(tt, "",new.file.bot) + tkbind(tt, "",load.file.arv) + tkbind(tt, "",save.file.arv) + tkbind(tt, "",save.file.arv) + tkbind(tt, "",naoimplementado) + tkbind(tt, "",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, "",OnOK) + Cancel.but <-tkbutton(destinyWindow,text=" Cancel ",command=OnCancel) + tkbind(destinyWindow, "",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, "",OnOK) + tkbind(Individuos.Value, "",OnOK) + tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOK) + tkbind(Individuos.Value, "",OnOK) + tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOK) + tkbind(Trialss.Value, "",OnOK) +# tkbind(Terminal.Value, "",OnOK) + + OnCancel <- function() + { + tkdestroy(dialogsimulationwindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + tkbind(dialogsimulationwindow, "",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, "",OnOkAdd) + tkbind(addvariableWindow, "",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, "",OnOkAdd) + tkbind(addvariableWindow, "",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, "",OnOK) + tkbind(variableWindow, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOK) + tkbind(displayInTableWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportgraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(CEsimtableWindow, "",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, "",OnOK) + tkbind(INBsimtableWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOKINB) + tkbind(plotINBtableWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(markovnodeWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancel", command=OnCancel) + + tkbind(markovnodeWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(nodenameWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(nodenameWindow, text=" Cancel ", command=OnCancel) + tkbind(nodenameWindow, "",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, "", OnOK) + + OnCancel <- function() + { + tkdestroy(notesWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(notesWindow, text=" Cancel ", command=OnCancel) + tkbind(notesWindow, "", 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "",OnOK) + tkbind(plotCEtableWindow, "",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, "",OnOK) + + OnCancel <- function() + { + tkdestroy(probWindow) + tkfocus(tt) + } + + Cancel.but <-tkbutton(probWindow,text=" Cancel ",command=OnCancel) + tkbind(probWindow, "",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, "",OnOK) + tkbind(propertiesWindow, "",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, "",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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(aGraphWindow, "", 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") + + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",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, "", OnOK) + tkbind(CEGraphWindow, "", 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, "", OnOK) + tkbind(graphsimulationWindow, "", 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, "",OnOK) + tkbind(statsSWindow, "",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, "",OnOK) + tkbind(filetypeWindow, "",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, "",OnOK) + tkbind(statsSWindow, "",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, "",OnOK) + tkbind(summarysimulationWindow, "",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, "",OnOK) + Cancel.but <-tkbutton(Frame2,text=" Cancel ",command=OnCancel) + tkbind(typenodeWindow, "",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, "",OnOK) + tkbind(entry.Value.effectiveness, "",OnOK) + tkbind(utilityWindow, "",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 From noreply at r-forge.r-project.org Fri Aug 8 06:37:57 2008 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 08 Aug 2008 04:37:57 -0000 Subject: [Arvore-commits] r3 - pkg/man Message-ID: <20080808043757.B79949C8F1@r-forge.r-project.org> Author: isix Date: 2008-08-08 06:37:57 +0200 (Fri, 08 Aug 2008) New Revision: 3 Modified: pkg/man/ArvoRe-package.Rd pkg/man/aceptability.sim.window.Rd pkg/man/acewindow.Rd pkg/man/addnodewindows.Rd pkg/man/arvore.Rd pkg/man/convert2matrix.Rd pkg/man/destinynodewindows.Rd pkg/man/dialog.simulation.window.Rd pkg/man/dialog.variable.window.Rd pkg/man/displayInTable.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/markov.coort.table.Rd pkg/man/markov.nodes.properties.Rd pkg/man/nodenamewindows.Rd pkg/man/notesnodewindows.Rd pkg/man/planoacewindow.Rd pkg/man/plot.tree.Rd pkg/man/probwindows.Rd pkg/man/properties.tree.Rd pkg/man/set.model.type.Rd pkg/man/set.value.Rd pkg/man/splashscreenArvoRe.Rd pkg/man/summary.simulation.window.Rd pkg/man/typenodewindows.Rd pkg/man/utilitywindows.Rd Log: Modified: pkg/man/ArvoRe-package.Rd =================================================================== --- pkg/man/ArvoRe-package.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/ArvoRe-package.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -15,7 +15,7 @@ Package: \tab ArvoRe\cr Type: \tab Package\cr Version: \tab 1.0\cr -Date: \tab 2008-06-25\cr +Date: \tab 2008-07-10\cr License: \tab What license is it under?\cr } ~~ An overview of how to use the package, including the most important ~~ Modified: pkg/man/aceptability.sim.window.Rd =================================================================== --- pkg/man/aceptability.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/aceptability.sim.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -103,14 +103,14 @@ PoinsOriginal <- 10 WTPL1Value <- tkentry(Frame1,width="20",textvariable=WTPL1var) - tkgrid(tklabel(Frame1,text="Valor do willingness-to-pay (WTP)"), + 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 do willingness-to-pay (WTP)"), + 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=" "), @@ -118,7 +118,7 @@ ### Numeric format settings ### numericSpinBox <- tkwidget(Frame1, "SpinBox", editable=FALSE, range = c(0,100,1), width = 3) - labeldigits <- tklabel(Frame1,text="N?mero de intervalor:") + labeldigits <- tklabel(Frame1,text="N?mero de intervalos:") tkgrid(labeldigits, numericSpinBox, sticky = "nw", padx = 5, pady = 5) tcl(numericSpinBox, "setvalue", paste("@", PoinsOriginal,sep = "")) @@ -147,7 +147,7 @@ Data.standart.CE <- subset(Data.CEA.CE, NT == respostaListbox) ans <- data.frame( Standart = rep(0,length(WTP))) - names.ans <- c("Standart") + names.ans <- c("Padr?o") for (i in 1:dim(Data.alternative.Cost)[1]) { @@ -156,7 +156,7 @@ var.inb <- ( WTP^2 ) * Data.alternative.Effectiveness$Variance[i] + Data.alternative.Cost$Variance[i] - - 2 * WTP * ( 00000 ) + 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) @@ -172,7 +172,7 @@ OnAC <- function(WTP, ACProbabilities) { ACGraphWindow <- tktoplevel() - title.window <- "?rvoRe - MC Simula??o - Graphics" + title.window <- "?rvoRe - MC Simula??o - Gr?ficos" tkwm.title(ACGraphWindow, title.window) frametext <- "Gr?fico" @@ -184,8 +184,8 @@ tkgrid(frameButton, sticky = "swe") # Image setings. - g.imgHeight <- 600/2 - g.imgWidth <- 800/2 + g.imgHeight <- 480 + g.imgWidth <- 640 # Canvas window configurations C.Height <- min(c(g.imgHeight, 768)) @@ -244,6 +244,10 @@ 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") { @@ -271,7 +275,11 @@ 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, @@ -298,7 +306,11 @@ 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() } } @@ -446,7 +458,7 @@ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK) tkbind(exportImgGraphWindow, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) tkbind(exportImgGraphWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") @@ -500,7 +512,7 @@ tkbind(ACsimtableWindow, "",OnOK) tkbind(ACsimtableWindow, "",OnOK) - posiciona.janela.no.mouse(ACsimtableWindow, 250, 310) + posiciona.janela.no.mouse(ACsimtableWindow, 310, 310) tkfocus(ACsimtableWindow) Modified: pkg/man/acewindow.Rd =================================================================== --- pkg/man/acewindow.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/acewindow.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -133,6 +133,9 @@ } 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) Modified: pkg/man/addnodewindows.Rd =================================================================== --- pkg/man/addnodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/addnodewindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -53,7 +53,7 @@ title <- "?rvoRe - Novo Nodo" tkwm.title(addnodeWindow,title) - NomeVar <- tclVar("New Node") + NomeVar <- tclVar("Novo Nodo") NomeEntryWidget <- tkentry(addnodeWindow,width="20",textvariable=NomeVar) tkgrid(tklabel(addnodeWindow,text="Nome do nodo")) tkgrid(NomeEntryWidget) @@ -124,7 +124,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(addnodeWindow,text=" Cancel ",command=OnCancel) + Cancel.but <-tkbutton(addnodeWindow,text=" Cancelar ",command=OnCancel) tkbind(addnodeWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/arvore.Rd =================================================================== --- pkg/man/arvore.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/arvore.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -190,7 +190,7 @@ 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,"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") Modified: pkg/man/convert2matrix.Rd =================================================================== --- pkg/man/convert2matrix.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/convert2matrix.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -109,7 +109,16 @@ } } + 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]),] @@ -121,6 +130,7 @@ x <- x[order(x[,i]),] } } + } x <- as.matrix(x) y <- as.matrix(y) @@ -144,7 +154,6 @@ rownames(utilityMAT) <- NULL colnames(destinyMAT) <- NULL rownames(destinyMAT) <- NULL - dl <- dim(destinyMAT)[1] destinyarray <- array(0,dl) for (i in 1:dl) { Modified: pkg/man/destinynodewindows.Rd =================================================================== --- pkg/man/destinynodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/destinynodewindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -110,9 +110,9 @@ tkfocus(tt) } - OK.but <-tkbutton(destinyWindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(destinyWindow,text=" OK ",command=OnOK) tkbind(destinyWindow, "",OnOK) - Cancel.but <-tkbutton(destinyWindow,text=" Cancel ",command=OnCancel) + Cancel.but <-tkbutton(destinyWindow,text=" Cancelar ",command=OnCancel) tkbind(destinyWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/dialog.simulation.window.Rd =================================================================== --- pkg/man/dialog.simulation.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/dialog.simulation.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -66,7 +66,7 @@ if (node.type == "M") { ############ MARKOV ############ dialogsimulationwindow <- tktoplevel() - title <- "?rvoRe - Markov Simulation" + title <- "?rvoRe - Simula??o Markov" tkwm.title(dialogsimulationwindow,title) Seedvar <- tclVar(0) @@ -132,7 +132,7 @@ } } - OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) tkbind(Seed.Value, "",OnOK) tkbind(Individuos.Value, "",OnOK) @@ -144,7 +144,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) tkbind(dialogsimulationwindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) @@ -155,7 +155,7 @@ if (node.type == "D") { ############ DECISION ############ dialogsimulationwindow <- tktoplevel() - title <- "?rvoRe - Markov Simulation" + title <- "?rvoRe - Simula??o Markov" tkwm.title(dialogsimulationwindow,title) Seedvar <- tclVar(0) @@ -289,7 +289,7 @@ } } - OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) tkbind(Seed.Value, "",OnOK) tkbind(Individuos.Value, "",OnOK) @@ -301,7 +301,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) tkbind(dialogsimulationwindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) @@ -312,7 +312,7 @@ if (node.type == "C") { ############ CHANCE ############ dialogsimulationwindow <- tktoplevel() - title <- "?rvoRe - Markov Simulation" + title <- "?rvoRe - Simula??o Markov" tkwm.title(dialogsimulationwindow,title) Seedvar <- tclVar(0) @@ -375,7 +375,7 @@ } } - OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(dialogsimulationwindow,text=" OK ",command=OnOK) tkbind(Seed.Value, "",OnOK) tkbind(Trialss.Value, "",OnOK) @@ -387,7 +387,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancel ", command=OnCancel) + Cancel.but <-tkbutton(dialogsimulationwindow, text=" Cancelar ", command=OnCancel) tkbind(dialogsimulationwindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/dialog.variable.window.Rd =================================================================== --- pkg/man/dialog.variable.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/dialog.variable.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -166,7 +166,7 @@ .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) + 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) @@ -310,7 +310,7 @@ .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) + 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) Modified: pkg/man/displayInTable.Rd =================================================================== --- pkg/man/displayInTable.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/displayInTable.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -190,7 +190,7 @@ .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) + 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) Modified: pkg/man/export.tree.graph.Rd =================================================================== --- pkg/man/export.tree.graph.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/export.tree.graph.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -175,7 +175,7 @@ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK) tkbind(exportgraphWindow, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) tkbind(exportgraphWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") Modified: pkg/man/icer.sim.window.Rd =================================================================== --- pkg/man/icer.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/icer.sim.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -110,6 +110,27 @@ 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, @@ -125,18 +146,32 @@ 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 * ( 00000 ) / + 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], @@ -145,11 +180,12 @@ CE.ratio = Data.alternative.Cost$Mean[i] / Data.alternative.Effectiveness$Mean[i], ICER = icer, Var.ICER = var.icer, - Sd.ICER = var.icer^0.5, + 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 <- abind(ans, ans.line, along = 1) + ans <- rbind(ans, ans.line) #, along = 1) + ans <- as.data.frame(ans) } ans <- as.data.frame(ans) @@ -159,6 +195,7 @@ 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() { Modified: pkg/man/inb.sim.window.Rd =================================================================== --- pkg/man/inb.sim.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/inb.sim.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -113,7 +113,7 @@ OnOK <- function() { respostaListbox <- n.treat[as.numeric(tkcurselection(tl))+1] - WTPVal <- as.integer(tclvalue(WTPvar)) + WTPVal <- as.numeric(tclvalue(WTPvar)) Data.alternative.Cost <- subset(Data.CEA.Cost, NT != respostaListbox) Data.standart.Cost <- subset(Data.CEA.Cost, NT == respostaListbox) @@ -142,7 +142,7 @@ var.inb <- ( WTPVal^2 ) * Data.alternative.Effectiveness$Variance[i] + Data.alternative.Cost$Variance[i] - - 2 * WTPVal * ( 00000 ) + 2 * WTPVal * ( Data.alternative.Cost$CovDcDe[i] ) alfa <- 0.05 # the significance ans.line <- data.frame( Strategy = Data.alternative.Cost$Treatment[i], @@ -164,7 +164,7 @@ # print(ans) - displayInTable(as.matrix(ans), title="ICER - An?lise de Custo-Efetividade", + 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) } Modified: pkg/man/inbwindow.Rd =================================================================== --- pkg/man/inbwindow.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/inbwindow.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -37,6 +37,7 @@ ## The function is currently defined as function(TheTree) { require(abind) + require(gplots) plotINBtableWindow <- tktoplevel() title <- "?rvoRe - INB" @@ -192,6 +193,10 @@ 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") { @@ -224,6 +229,11 @@ 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, @@ -255,17 +265,58 @@ 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 = Data.standart$Node.name, + ans <- data.frame( Strategy = as.character(Data.standart$Node.name), Cost = Data.standart$Mean.Cost, Incr.Cost = 0, Effectiveness = Data.standart$Mean.Effectiveness, @@ -275,7 +326,7 @@ ) for (i in 1:dim(Data.alternative)[1]) { - ans.line <- data.frame( Strategy = Data.alternative$Node.name[i], + 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], @@ -292,10 +343,11 @@ 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, + 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) @@ -304,163 +356,239 @@ 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) + OnExportGraphic <- function() { - 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) + LIVal <- as.numeric(tclvalue(LIvar)) +# print(LIVal) + LSVal <- as.numeric(tclvalue(LSvar)) +# print(LSVal) + NPVal <- as.numeric(tclvalue(NPvar)) +# print(NPVal) - tkgrid( tklabel(frameUpper,text="Formato de imagem"),sticky="n", columnspan = 2) + 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 + ) - 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") + 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) - OnOK <- function(...) - { - img.height <- as.numeric(tclvalue(tcl(numericSpinBox,"getvalue"))) - if ((is.numeric(img.height) )&&(!is.na(img.height))) g.imgHeight <- img.height + 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) - img.width <- as.numeric(tclvalue(tcl(numericSpinBox2,"getvalue"))) - if ((is.numeric(img.width) )&&(!is.na(img.width))) g.imgWidth <- img.width +# print(cedata) - 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) + 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) - 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) + 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") } - } else { - if (ImgFormatselected == "jpg") { - .Filename <- tclvalue(tkgetSaveFile(filetypes="{{Jpeg Image Files} {.jpg}} {{All files} *}")) + } + + 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 != ".jpg" ) .Filename <- paste(.Filename, ".jpg", sep="") - - if (!file.exists(.Filename)) file.remove(.Filename) + if ( ans != ".png" ) .Filename <- paste(.Filename, ".png", sep="") - 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, + 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) } - 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, "",OnOK) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) + tkbind(exportImgGraphWindow, "",OnCancel) + tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") - OnCancel <- function() - { - tkdestroy(exportImgGraphWindow) - tkwm.deiconify(plotINBtableWindow) - tkfocus(plotINBtableWindow) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + tkbind(rb1, "",Onformat) + tkbind(rb2, "",Onformat) + tkbind(rb3, "",Onformat) + + tkgrid(framePlot) + tkfocus(exportImgGraphWindow) + # posiciona.janela.no.mouse(exportImgGraphWindow) } - - .Width.but <- 10 - .Height.but <- 1 - - OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK) - tkbind(exportImgGraphWindow, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) - tkbind(exportImgGraphWindow, "",OnCancel) - tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") - - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",Onformat) - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",Onformat) - - tkgrid(framePlot) - tkfocus(exportImgGraphWindow) -# posiciona.janela.no.mouse(exportImgGraphWindow) } Build.INB <- function(wtp, cedata, to.export = FALSE) { @@ -483,7 +611,88 @@ } - OnExportText <- function(Original.Dada) { + 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) @@ -515,10 +724,10 @@ ans <- substr(fileName,nchar(fileName)-3,nchar(fileName)) if ( fileextChoice == ".csv" ) { if (ans == ".csv") { - write.csv2(Original.Dada, file = fileName, row.names = FALSE) + write.csv2(Original.Dada, file = fileName, row.names = TRUE) } else { fileName <- paste(fileName, ".csv", sep = "") - write.csv2(Original.Dada, file = fileName, row.names = FALSE) + write.csv2(Original.Dada, file = fileName, row.names = TRUE) } } if ( fileextChoice == ".txt" ) { @@ -550,7 +759,7 @@ .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) + 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) @@ -561,6 +770,7 @@ tkbind(filetypeWindow, "",OnOK) tkfocus(filetypeWindow) + } } OnOKINB <- function() { @@ -635,10 +845,11 @@ 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, + 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) @@ -665,7 +876,7 @@ 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)) ) + 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) Modified: pkg/man/markov.coort.table.Rd =================================================================== --- pkg/man/markov.coort.table.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/markov.coort.table.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -52,21 +52,19 @@ MatrixTheTree <- convert2matrix(TheTree) x <- MatrixTheTree$x # Structure matrix y <- MatrixTheTree$y # Node name matrix - typeMAT <- MatrixTheTree$typeMAT # Node type 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 @@ -75,14 +73,16 @@ MARKOV.states.final.effectiveness.rwd <- as.numeric(markov.propertiesMAT$Final.effectiveness) # MARKOV.states MARKOV.states.names <- SummaryTreeTable$Node.name -# print(MARKOV.states.names) + # 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.utilities <- list() MARKOV.states.costs <- list() MARKOV.states.effectiveness <- list() @@ -96,7 +96,7 @@ 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.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 ? @@ -109,7 +109,7 @@ 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) + #~ sub.typeMAT <- matrix(c("D",sub.typeMAT), 1, n.mat) } else { sub.probMAT[,1] <- 1.0 # Agora o nodo raiz recebe prob = 1. } @@ -117,7 +117,7 @@ # 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 @@ -125,7 +125,6 @@ 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. @@ -135,30 +134,17 @@ 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()) - + # 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) @@ -166,9 +152,7 @@ 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) @@ -196,13 +180,13 @@ # 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 + .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 @@ -211,7 +195,7 @@ Coorte.Effec.LINE <- matrix(0,1,initial.coort) for (i in 1:num.markov.states ) { - positions <- which(Coorte.Ind[.stage,] == MARKOV.states[i]) + positions <- which(Coorte.Ind[.stage - 1,] == MARKOV.states[i]) indvs <- length(positions) if ( indvs != 0 ) { arvore <- MARKOV.states.arvores[[as.character(MARKOV.states[i])]] @@ -220,7 +204,6 @@ 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) @@ -234,6 +217,13 @@ 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) @@ -241,41 +231,25 @@ # 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] + 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] } -# 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) +# 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 = "") -# 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 } Modified: pkg/man/markov.nodes.properties.Rd =================================================================== --- pkg/man/markov.nodes.properties.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/markov.nodes.properties.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -160,7 +160,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancel", command=OnCancel) + Cancel.but <-tkbutton(markovnodeWindow, width=.Width.but, height=.Height.but, text="Cancelar", command=OnCancel) tkbind(markovnodeWindow, "",OnCancel) Modified: pkg/man/nodenamewindows.Rd =================================================================== --- pkg/man/nodenamewindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/nodenamewindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -66,7 +66,7 @@ tkfocus(nodenameWindow) } } - OK.but <-tkbutton(nodenameWindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(nodenameWindow,text=" OK ",command=OnOK) tkbind(entry.Value, "",OnOK) OnCancel <- function() @@ -75,7 +75,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(nodenameWindow, text=" Cancel ", command=OnCancel) + Cancel.but <-tkbutton(nodenameWindow, text=" Cancelar ", command=OnCancel) tkbind(nodenameWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/notesnodewindows.Rd =================================================================== --- pkg/man/notesnodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/notesnodewindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -65,7 +65,7 @@ refreshF5() tkfocus(tt) } - OK.but <-tkbutton(notesWindow, text=" OK ", command=OnOK) + OK.but <-tkbutton(notesWindow, text=" OK ", command=OnOK) tkbind(entry.Value, "", OnOK) OnCancel <- function() @@ -74,7 +74,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(notesWindow, text=" Cancel ", command=OnCancel) + Cancel.but <-tkbutton(notesWindow, text=" Cancelar ", command=OnCancel) tkbind(notesWindow, "", OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/planoacewindow.Rd =================================================================== --- pkg/man/planoacewindow.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/planoacewindow.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -53,8 +53,8 @@ tkgrid(frameButton, sticky = "swe") # Image setings. - g.imgHeight <- 600/2 - g.imgWidth <- 800/2 + g.imgHeight <- 480 + g.imgWidth <- 640 # Canvas window configurations C.Height <- min(c(g.imgHeight, 768)) @@ -96,26 +96,26 @@ img.type <- "png" img.quality <- 90 - plot.it.to.image <- function(AllTreatCost, AllTreatEffectiveness, treatments.colors.plot, + plot.it.to.image <- function(AllTreatEffectiveness, AllTreatCost, treatments.colors.plot, treatments.label.plot, .Filename, img.type = "png", img.quality = 90, - img.width = 400, img.height = 400, ...) { + 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, AllTreatCost, - col = treatments.colors.plot, pch = "*", main = Graphtitle, + plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost), + col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle, xlab = xlabel, ylab = ylabel) - smartlegend( x="left", y= "top", inset=0, #smartlegend parameters + 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") - 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") { @@ -125,16 +125,16 @@ Graphtitle <- "Plano Custo-Efetividade" xlabel <- "Efetividade" ylabel <- "Custo" - plot(AllTreatEffectiveness, AllTreatCost, - col = treatments.colors.plot, pch = "*", main = Graphtitle, + plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost), + col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle, xlab = xlabel, ylab = ylabel) - smartlegend( x="left", y= "top", inset=0, #smartlegend parameters + 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") - 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, @@ -143,16 +143,16 @@ Graphtitle <- "Plano Custo-Efetividade" xlabel <- "Efetividade" ylabel <- "Custo" - plot(AllTreatEffectiveness, AllTreatCost, - col = treatments.colors.plot, pch = "*", main = Graphtitle, + plot(c(0,AllTreatEffectiveness), c(0,AllTreatCost), + col = c(0,treatments.colors.plot), pch = "*", main = Graphtitle, xlab = xlabel, ylab = ylabel) - smartlegend( x="left", y= "top", inset=0, #smartlegend parameters + 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") - for (i in length(AllTreatEffectiveness)) { - lines(c(0,AllTreatEffectiveness[i]), c(0,AllTreatCost[i]), col = treatments.colors.plot[i]) - } dev.off() } } @@ -310,7 +310,7 @@ OK.but <-tkbutton(frameLower,text="OK", width=.Width.but, height=.Height.but, command=OnOK) tkbind(exportImgGraphWindow, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) + Cancel.but <-tkbutton(frameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) tkbind(exportImgGraphWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") Modified: pkg/man/plot.tree.Rd =================================================================== --- pkg/man/plot.tree.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/plot.tree.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -45,7 +45,6 @@ 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) Modified: pkg/man/probwindows.Rd =================================================================== --- pkg/man/probwindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/probwindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -64,7 +64,7 @@ tkfocus(probWindow) } } - OK.but <-tkbutton(probWindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(probWindow,text=" OK ",command=OnOK) tkbind(entry.Value, "",OnOK) OnCancel <- function() @@ -73,7 +73,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(probWindow,text=" Cancel ",command=OnCancel) + Cancel.but <-tkbutton(probWindow,text=" Cancelar ",command=OnCancel) tkbind(probWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/properties.tree.Rd =================================================================== --- pkg/man/properties.tree.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/properties.tree.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -60,7 +60,7 @@ frameFontPlot <- tkwidget(frameRight, "labelframe", borderwidth = 2, relief = "groove", text = titleframe) ### Method settings ### - metodos <- c("Simple Decision (simple payoff)", "Cost-Effectiveness") + metodos <- c("Decis?o simples (simple payoff)", "Custo-Efetividade") method.arvore <- c("SD", "CE") methodBox <- tkwidget(frameUpper, "ComboBox", editable=FALSE, values=metodos, width = 30) @@ -206,7 +206,7 @@ } 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) + 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, "",OnOK) Modified: pkg/man/set.model.type.Rd =================================================================== --- pkg/man/set.model.type.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/set.model.type.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -42,6 +42,7 @@ } else { cat("Error!! \n") } + refreshF5() assign(".workstatus", "unsaved", .EnvironmentArvoRe) } } Modified: pkg/man/set.value.Rd =================================================================== --- pkg/man/set.value.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/set.value.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -161,7 +161,7 @@ .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) + Cancel.but <-tkbutton(FrameLower,text="Cancelar", width=.Width.but, height=.Height.but, command=OnCancel) tkbind(setvalueWindow, "",OnCancel) Modified: pkg/man/splashscreenArvoRe.Rd =================================================================== --- pkg/man/splashscreenArvoRe.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/splashscreenArvoRe.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -47,6 +47,7 @@ } } posiciona.janela.tela(splashArvoRe) + tkfocus(splashArvoRe) tcl("tkwait","window",splashArvoRe) } } Modified: pkg/man/summary.simulation.window.Rd =================================================================== --- pkg/man/summary.simulation.window.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/summary.simulation.window.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -73,7 +73,8 @@ 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)) + Quartil1 = array(,0), Quartil2 = array(,0), CovDcDe = array(,0), + Time = array(,0)) for (i in treatments.sim) { @@ -120,10 +121,14 @@ # 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) + statisticsData <- summary(Data, na.rm = TRUE) - meanData <- mean(Data, na.rm = TRUE) - varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2) + 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] @@ -131,15 +136,37 @@ quartil1 <- statisticsData[2] quartil3 <- statisticsData[5] - EvarData <- varData + 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, Time = tempo) + 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)") @@ -183,30 +210,58 @@ 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) + Data <- apply( Mktable$Cost, 2, sum, na.rm = TRUE) ntreat <- length(Data) - statisticsData <- summary(Data) + statisticsData <- summary(Data, na.rm = TRUE) - meanData <- mean(Data, na.rm = TRUE) - varData <- ( 1 / (ntreat*(ntreat-1)) ) * sum( (Data - meanData)^2) + 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] + quartil3 <- statisticsData[5] - CvarData <- varData + 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, Time = tempo) + 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)") @@ -249,9 +304,6 @@ 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") @@ -261,12 +313,13 @@ # 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) + 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) + statisticsData <- summary(Data, na.rm = TRUE) meanData <- statisticsData[4] - varData <- var(Data, na.rm = TRUE, use = "complete.obs") + varData <- var(Data, na.rm = TRUE) sdData <- sqrt(varData) medianData <- statisticsData[3] minData <- statisticsData[1] @@ -278,13 +331,14 @@ 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) - - + Quartil1 = quartil1, Quartil2 = quartil3, + CovDcDe = NA, Time = tempo) + Alltreatmentstable <- abind(Alltreatmentstable, line.data.summary, along=1) } - rm(Data, statisticsData, Mktable) + # 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 @@ -299,6 +353,7 @@ 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) @@ -329,785 +384,14 @@ tkfocus(tt) } - OnGraph <- function() { + 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]] - 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, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) - tkbind(exportImgGraphWindow, "",OnCancel) - tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") - - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",Onformat) - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",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, "", OnOK) - tkbind(aGraphWindow, "", 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, "",OnOK) - Cancel.but <-tkbutton(frameLower,text="Cancel", width=.Width.but, height=.Height.but, command=OnCancel) - tkbind(exportImgGraphWindow, "",OnCancel) - tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5, columnspan = 2, sticky = "s") - - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",Onformat) - tkbind(rb1, "",Onformat) - tkbind(rb2, "",Onformat) - tkbind(rb3, "",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, "", OnOK) - tkbind(CEGraphWindow, "", 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, "", OnOK) - tkbind(graphsimulationWindow, "", OnCancel) - - tkfocus(graphsimulationWindow) -# OnGraph ---------------------------------------------------------------------------------------------------------------- tkfocus(summarysimulationWindow) - + onGraph.summary.simwindow(Mktable, Alltreatmentstable, selected.treatment) } OnText <- function() { @@ -1126,14 +410,14 @@ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0) OnNM <- function() { - WTPVal <- as.integer(tclvalue(WTPvar)) + 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) - DataEffectiveness <- apply(Mktable$Effectiveness,2,sum) + 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, @@ -1148,8 +432,8 @@ # 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) + 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, @@ -1175,21 +459,21 @@ } OnNH <- function() { - WTPVal <- as.integer(tclvalue(WTPvar)) + WTPVal <- as.numeric(tclvalue(WTPvar)) selected.treatment <- treatments.sim[1] Mktable <- Simlist[[selected.treatment]] - # The NMB ----------------------------------------------------------------------- + # The NHB ----------------------------------------------------------------------- # 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 + DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE) + DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) + Data <- DataEffectiveness - DataCost / WTPVal - NMBtable <- data.frame( Cost = DataCost, + NHBtable <- data.frame( Cost = DataCost, Effectiveness = DataEffectiveness, - NMB = Data) - namesvariables <- c(".Cost", ".Effectiveness", ".NMB") - names(NMBtable) <- paste(selected.treatment,namesvariables,sep="") + 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) ) { @@ -1198,28 +482,28 @@ # 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 + DataCost <- apply(Mktable$Cost,2,sum, na.rm = TRUE) + DataEffectiveness <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) + Data <- DataEffectiveness - DataCost / WTPVal - newNMBtable <- data.frame( Cost = DataCost, + newNHBtable <- data.frame( Cost = DataCost, Effectiveness = DataEffectiveness, - NMB = Data) - names(newNMBtable) <- paste(selected.treatment,namesvariables,sep="") + NHB = Data) + names(newNHBtable) <- paste(selected.treatment,namesvariables,sep="") # Guarda as informa??es importantes - NMBtable <- abind(NMBtable, newNMBtable, along=2) + NHBtable <- abind(NHBtable, newNHBtable, along=2) } } Trial <- 1:length(DataCost) - NMBtable <- abind(Trial, NMBtable, along=2) - names(NMBtable) <- c("Trial", names(NMBtable)) + NHBtable <- abind(Trial, NHBtable, along=2) + names(NHBtable) <- c("Trial", names(NHBtable)) - tituloNMB <- "Estat?sticas - Net Health Benefits" - NMBtable <- as.matrix(NMBtable) + tituloNHB <- "Estat?sticas - Rede de Benef?cio Sa?de (NHB)" + NHBtable <- as.matrix(NHBtable) - displayInTable(NMBtable, title = tituloNMB, height=min(10,dim(NMBtable)[1]), width= min(10,dim(NMBtable)[2]), - nrow=dim(NMBtable)[1],ncol=dim(NMBtable)[2], + 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) } @@ -1230,8 +514,8 @@ 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) + 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, @@ -1246,8 +530,8 @@ # 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) + 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, @@ -1271,13 +555,18 @@ 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) + 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) @@ -1344,8 +633,8 @@ 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(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)) @@ -1377,8 +666,8 @@ 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(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)) @@ -1477,7 +766,7 @@ .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) + 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) @@ -1492,8 +781,6 @@ } OnStatsRep <- function() { - - StatsData <- Alltreatmentstable[ order(Alltreatmentstable$Treatment, Alltreatmentstable$Data),] assign("StatsData", StatsData, .EnvironmentArvoRe) @@ -1512,7 +799,7 @@ frameButtons <- tkframe(statsSWindow, relief="groove", borderwidth = 0) OnNM <- function() { - WTPVal <- as.integer(tclvalue(WTPvar)) + WTPVal <- as.numeric(tclvalue(WTPvar)) NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0), Variance = array(,0), Sd = array(,0), Median = array(,0), @@ -1525,9 +812,10 @@ # 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) + Data <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) * + WTPVal - apply(Mktable$Cost,2,sum, na.rm = TRUE) - statisticsData <- summary(Data) + statisticsData <- summary(Data, na.rm = TRUE) meanData <- statisticsData[4] varData <- var(Data, na.rm = TRUE, use = "complete.obs") @@ -1546,7 +834,7 @@ NMBtable <- abind(NMBtable, line.data.summary, along=1) } - tituloNMB <- "Estat?sticas - Net Monetary Benefits" + 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]), @@ -1556,7 +844,7 @@ } OnNH <- function() { - WTPVal <- as.integer(tclvalue(WTPvar)) + WTPVal <- as.numeric(tclvalue(WTPvar)) NMBtable <- data.frame(Treatment = array(,0), Mean = array(,0), Variance = array(,0), Sd = array(,0), Median = array(,0), @@ -1569,9 +857,10 @@ # 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) + Data <- apply(Mktable$Effectiveness,2,sum, na.rm = TRUE) * + apply(Mktable$Cost,2,sum, na.rm = TRUE) / WTPVal - statisticsData <- summary(Data) + statisticsData <- summary(Data, na.rm = TRUE) meanData <- statisticsData[4] varData <- var(Data, na.rm = TRUE, use = "complete.obs") @@ -1590,7 +879,7 @@ NMBtable <- abind(NMBtable, line.data.summary, along=1) } - tituloNMB <- "Estat?sticas - Net Monetary Benefits" + 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]), @@ -1601,10 +890,6 @@ } 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) @@ -1625,12 +910,12 @@ .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) + 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 benf?cios (INB)", width=.Width.but, + INB.but <-tkbutton(frameOverall,text="Incremento da rede de benef?cios (INB)", width=.Width.but, height=.Height.but, command= function() OnINB(StatsData)) @@ -1665,17 +950,22 @@ # 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=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) + 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, "",OnOK) tkbind(summarysimulationWindow, "",OnOK) Modified: pkg/man/typenodewindows.Rd =================================================================== --- pkg/man/typenodewindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/typenodewindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -184,9 +184,9 @@ tkfocus(tt) } - OK.but <-tkbutton(Frame2,text=" OK ",command=OnOK) + OK.but <-tkbutton(Frame2,text=" OK ",command=OnOK) tkbind(typenodeWindow, "",OnOK) - Cancel.but <-tkbutton(Frame2,text=" Cancel ",command=OnCancel) + Cancel.but <-tkbutton(Frame2,text=" Cancelar ",command=OnCancel) tkbind(typenodeWindow, "",OnCancel) tkgrid(OK.but, Cancel.but, sticky = "s", padx = 5, pady = 5) Modified: pkg/man/utilitywindows.Rd =================================================================== --- pkg/man/utilitywindows.Rd 2008-08-08 04:36:00 UTC (rev 2) +++ pkg/man/utilitywindows.Rd 2008-08-08 04:37:57 UTC (rev 3) @@ -83,7 +83,7 @@ tkfocus(utilityWindow) } } - OK.but <-tkbutton(utilityWindow,text=" OK ",command=OnOK) + OK.but <-tkbutton(utilityWindow,text=" OK ",command=OnOK) OnCancel <- function() { @@ -91,7 +91,7 @@ tkfocus(tt) } - Cancel.but <-tkbutton(utilityWindow,text=" Cancel ",command=OnCancel) + Cancel.but <-tkbutton(utilityWindow,text=" Cancelar ",command=OnCancel) tkbind(entry.Value, "",OnOK) tkbind(entry.Value.effectiveness, "",OnOK)