diff --git a/gWidgets/density.R b/gWidgets/density.R new file mode 100644 index 0000000000000000000000000000000000000000..678c4ef112826502829c789bd40a75a588019827 --- /dev/null +++ b/gWidgets/density.R @@ -0,0 +1,47 @@ +##---------------------------------------------------------------------- +## Definições da sessão. + +require(gWidgetstcltk) +options(guiToolkit="tcltk") +## options(guiToolkit="RGtk2") + +## Vetor de valores para o qual será feito o histograma. +x <- precip + +##------------------------------------------- +## Função reativa. Sem argumentos! + +density.reactive <- function(...){ + dn <- density(x, + kernel=svalue(sk), + width=svalue(sw)) + plot(dn, main=NA, xlab="Precipitação", ylab="Densidade") + if (svalue(rg)){ + rug(x) + } +} + +##------------------------------------------- +## Interface. + +w <- gwindow("Densidade empÃrica") +tbl <- glayout(container=w) +kf <- eval(formals(density.default)$kernel) ## Funções kernel. +tbl[1, 1] <- "Escolha uma função kernel:" +tbl[2, 1, expand=TRUE] <- ( + sk <- gcombobox(items=kf, + ## selected="gaussian", + coerce.with="as.character", + container=tbl, handler=density.reactive)) +dn <- density(x, kernel="gaussian") +dn$w <- (dn$bw*4)*c(0.5, 3, 1) +tbl[3, 1] <- "Largura de banda" +tbl[4, 1, expand=TRUE] <- ( + sw <- gslider(from=dn$w[1], to=dn$w[2], + by=diff(dn$w[-3])/100, value=dn$w[3], + container=tbl, handler=density.reactive)) +tbl[5, 1, expand=TRUE] <- ( + rg <- gcheckbox("Colocar rug?", + container=tbl, handler=density.reactive)) + +##---------------------------------------------------------------------- diff --git a/gWidgets/hist.R b/gWidgets/hist.R new file mode 100644 index 0000000000000000000000000000000000000000..47130fb91337b0cd3a687ae054b94d362a8815f5 --- /dev/null +++ b/gWidgets/hist.R @@ -0,0 +1,123 @@ +##----------------------------------------------------------------------------- +## Definições da sessão. + +## require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") +## options(guiToolkit="RGtk2") + +## Vetor de valores para o qual será feito o histograma. +x <- precip + +##----------------------------------------------------------------------------- +## Caso 1: cores são especificadas por meio de trinca RGB. + +## Função reativa. Sem argumentos! +hist.reactive <- function(...){ + hist(x, + col=rgb( + red=svalue(sr), + green=svalue(sg), + blue=svalue(sb)), + breaks=svalue(sl), + main=NULL, + ylab="Frequência absoluta", + xlab="Precipitação") + if(svalue(rg)){ + rug(x) + } +} + +##-------------------------------------------- +w <- gwindow("Histograma") +tbl <- glayout(container=w) +##-------------------------------------------- +tbl[1, 1] <- "Escolha a cor em RGB" +tbl[2, 1] <- (sr <- + gspinbutton(from=0, to=1, by=0.05, value=0.5, + container=tbl, handler=hist.reactive)) +tbl[3, 1] <- (sg <- + gspinbutton(from=0, to=1, by=0.05, value=0.5, + container=tbl, handler=hist.reactive)) +tbl[4, 1] <- (sb <- + gspinbutton(from=0, to=1, by=0.05, value=0.5, + container=tbl, handler=hist.reactive)) +##-------------------------------------------- +tbl[5, 1] <- "Sugestão do número de classes" +tbl[6, 1, expand=TRUE] <- (sl <- + gslider(from=1, to=100, by=1, value=10, + container=tbl, handler=hist.reactive)) +##-------------------------------------------- +tbl[7, 1, expand=TRUE] <- (rg <- + gcheckbox("Colocar rug?", + container=tbl, handler=hist.reactive)) + +##----------------------------------------------------------------------------- +## Caso 2: cores são especificadas em formato html (hexadecimal). + +## Função reativa. Sem argumentos! +hist.reactive <- function(...){ + hist(x, + col=paste0("#", svalue(shtml)), + breaks=svalue(sl)) + if(svalue(rg)){ + rug(x) + } +} + +##-------------------------------------------- +w <- gwindow("Histograma") +tbl <- glayout(container=w) +##-------------------------------------------- +tbl[1,1] <- "Especifique cor em formato html:" +tbl[1,2, expand=TRUE] <- (shtml <- + gedit(text="FF0000", + initial.msg="FF00CC", + coerce.with="as.character", width=6, + container=tbl, handler=hist.reactive)) +addhandlerchanged(shtml, handler=hist.reactive) +##-------------------------------------------- +tbl[3,1] <- "Sugestão do número de classes" +tbl[4, 1, expand=TRUE] <- (sl <- + gslider(from=1, to=20, by=1, value=10, + container=tbl, handler=hist.reactive)) +##-------------------------------------------- +tbl[5, 1, expand=TRUE] <- (rg <- + gcheckbox("Colocar rug?", + container=tbl, handler=hist.reactive)) + +##----------------------------------------------------------------------------- +## Caso 3: cores são escolhidas em uma lista de cores disponÃveis. + +## Função reativa. Sem argumentos! +hist.reactive <- function(...){ + hist(x, + col=svalue(scolors), + breaks=svalue(sl)) + if(svalue(rg)){ + rug(x) + } +} + +##-------------------------------------------- +w <- gwindow("Histograma") +tbl <- glayout(container=w) +##-------------------------------------------- +tbl[1,1] <- "Escolha uma das cores disponÃveis:" +tbl[1,2, expand=TRUE] <- (scolors <- + gcombobox(items=colors(), + selected="red", + coerce.with="as.character", + container=tbl, handler=hist.reactive)) +## addhandlerchanged(shtml, handler=hist.reactive) +##-------------------------------------------- +tbl[3,1] <- "Sugestão do número de classes" +tbl[4, 1, expand=TRUE] <- (sl <- + gslider(from=1, to=100, by=1, value=10, + container=tbl, handler=hist.reactive)) +##-------------------------------------------- +tbl[5, 1, expand=TRUE] <- (rg <- + gcheckbox("Colocar rug?", + container=tbl, handler=hist.reactive)) + +##----------------------------------------------------------------------------- diff --git a/gWidgets/hist_Button.R b/gWidgets/hist_Button.R new file mode 100644 index 0000000000000000000000000000000000000000..f7514061efb12a6e2c4e8b1aec2ebc5952cd3c8c --- /dev/null +++ b/gWidgets/hist_Button.R @@ -0,0 +1,18 @@ +## Botão de ação (gbutton) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) + +hist.reactive <- function(...){ + col <- sample(colors(), size=1) + plot(ht, main=NULL, + ylab="Frequência absoluta", xlab="Precipitação", + col=col, sub=col) +} + +w <- gwindow("Histograma") +gbutton(text="Nova cor!", container=w, handler=hist.reactive) diff --git a/gWidgets/hist_Button.gif b/gWidgets/hist_Button.gif new file mode 100644 index 0000000000000000000000000000000000000000..88b03248430f781e8649b5838f9c5d02d7a77813 Binary files /dev/null and b/gWidgets/hist_Button.gif differ diff --git a/gWidgets/hist_Checkbox.R b/gWidgets/hist_Checkbox.R new file mode 100644 index 0000000000000000000000000000000000000000..bb45caca2a981ed66b0ee38a45b57d2a6cc249ba --- /dev/null +++ b/gWidgets/hist_Checkbox.R @@ -0,0 +1,27 @@ +## Caixa de seleção (gcheckbox) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) +col <- rep("#3366CC", length(ht$counts)) + +hist.reactive <- function(...){ + if(svalue(modal)){ + col[which.max(ht$counts)] <- "#142952" + } + plot(ht, col=col, main=NULL, + ylab="Frequência absoluta", + xlab="Precipitação") + if(svalue(rg)){ + rug(x) + } +} + +w <- gwindow("Histograma") +rg <- gcheckbox(text="Marcar sobre eixo com os valores?", + checked=FALSE, container=w, handler=hist.reactive) +modal <- gcheckbox(text="Destacal a classe modal?", + checked=FALSE, container=w, handler=hist.reactive) diff --git a/gWidgets/hist_Checkbox.gif b/gWidgets/hist_Checkbox.gif new file mode 100644 index 0000000000000000000000000000000000000000..201e00be028d8ec8a24464bda6f3712bf97908c4 Binary files /dev/null and b/gWidgets/hist_Checkbox.gif differ diff --git a/gWidgets/hist_Checkboxgroup.R b/gWidgets/hist_Checkboxgroup.R new file mode 100644 index 0000000000000000000000000000000000000000..140ae9b1be7817b2d9dde427f55ca535002eebc0 --- /dev/null +++ b/gWidgets/hist_Checkboxgroup.R @@ -0,0 +1,26 @@ +## Caixas de seleção múltipla (gcheckboxgroup) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) +nc <- length(ht$counts) + +cols <- c(Vermelho="#F81D54", Amarelo="#FF9F1E", Azul="#2791E1", Verde="#72F51D") +cols2 <- c(cols, rev(cols)) + +hist.reactive <- function(...){ + seqcol <- colorRampPalette(cols2[svalue(colors)]) + plot(ht, col=seqcol(nc), + main=NULL, + ylab="Frequência absoluta", + xlab="Precipitação") +} + +w <- gwindow("Histograma") +g <- gframe(text="Escolha as cores para interpolar:", container=w) +colors <- gcheckboxgroup(items=names(cols2), + checked=c(TRUE, is.na(cols2)[-1]), + container=g, handler=hist.reactive) diff --git a/gWidgets/hist_Checkboxgroup.gif b/gWidgets/hist_Checkboxgroup.gif new file mode 100644 index 0000000000000000000000000000000000000000..cd483ea80773614d3c392ab1b5066cdb09d5fbfb Binary files /dev/null and b/gWidgets/hist_Checkboxgroup.gif differ diff --git a/gWidgets/hist_Numeric.R b/gWidgets/hist_Numeric.R new file mode 100644 index 0000000000000000000000000000000000000000..bf0601eb704eb4efc57e2af2bad4896941190dbb --- /dev/null +++ b/gWidgets/hist_Numeric.R @@ -0,0 +1,36 @@ +## Botões de incremento (gspimbutton) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) + +hist.reactive <- function(...){ + m <- svalue(mar) + par(mar=c(m, m, 1, 1)) + plot(ht, col="#660066", + main=NULL, axes=FALSE, ann=FALSE, + xaxt="n", yaxt="n") + box(bty="L") + axis(side=1, cex.axis=svalue(cexaxis)) + axis(side=2, cex.axis=svalue(cexaxis)) + title(ylab="Frequência absoluta", + xlab="Precipitação", + line=svalue(line)) +} + +w <- gwindow("Histograma") +g <- gframe(text="Tamanho do texto dos eixos:", container=w) +mar <- gspinbutton(from=3, to=7, by=0.5, value=5, + container=g, handler=hist.reactive) +svalue(mar) <- 5 +g <- gframe(text="Tamanho do texto dos eixos:", container=w) +cexaxis <- gspinbutton(from=0.5, to=2, by=0.1, value=1, + container=g, handler=hist.reactive) +svalue(cexaxis) <- 1 +g <- gframe(text="Distância dos rótulos dos eixos:", container=w) +line <- gspinbutton(from=1, to=4, by=0.1, value=3, + container=g, handler=hist.reactive) +svalue(line) <- 3 diff --git a/gWidgets/hist_Numeric.gif b/gWidgets/hist_Numeric.gif new file mode 100644 index 0000000000000000000000000000000000000000..5c067205e75a6fd3d96f54ce5681f18c638e7f35 Binary files /dev/null and b/gWidgets/hist_Numeric.gif differ diff --git a/gWidgets/hist_Radio.R b/gWidgets/hist_Radio.R new file mode 100644 index 0000000000000000000000000000000000000000..98f0e4e2bcacc5009d149647cf5216dac5cc96a5 --- /dev/null +++ b/gWidgets/hist_Radio.R @@ -0,0 +1,29 @@ +## Múltipla escolha (gradio) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) + +choices <- c(Turquesa="#00CC99", + Azul="#0066FF", + Rosa="#FF3399", + Laranja="#FF6600", + Roxo="#660066", + "Verde limão"="#99FF33") + +hist.reactive <- function(...){ + plot(ht, + col=choices[svalue(col)], + main=NULL, + ylab="Frequência absoluta", + xlab="Precipitação") +} + +w <- gwindow("Histograma") +g <- gframe(text="Escolha a cor para as barras:", container=w) +col <- gradio(items=names(choices), + selected=1, + container=g, handler=hist.reactive) diff --git a/gWidgets/hist_Radio.gif b/gWidgets/hist_Radio.gif new file mode 100644 index 0000000000000000000000000000000000000000..0a78b3e601088c8a301dda0a280e68096f5217ce Binary files /dev/null and b/gWidgets/hist_Radio.gif differ diff --git a/gWidgets/hist_Select.R b/gWidgets/hist_Select.R new file mode 100644 index 0000000000000000000000000000000000000000..e65f9cc9504fe0083cc79aa134b334f05c86a180 --- /dev/null +++ b/gWidgets/hist_Select.R @@ -0,0 +1,38 @@ +## Caixas de seleção (gcombobox) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +Nclass <- c("Sturges", "Scott", "Freedman-Diaconis") +Obj <- c("precip","rivers","islands") + +hist.reactive <- function(...){ + L <- switch(svalue(obj), + precip=list(x=precip, xlab="Precipitação anual média (polegadas)"), + rivers=list(x=rivers, xlab="Comprimento dos rios (milhas)"), + islands=list(x=islands, xlab="Ãrea de ilhas (1000 milhas quadradas)")) + hist(L$x, + breaks=svalue(nclass), + col="#8F0047", + main=NULL, + ylab="Frequência absoluta", + xlab=L$xlab) + rug(L$x) +} + +w <- gwindow("Histograma") +glabel(text="Escolha o conjunto de dados:", container=w) +obj <- gcombobox(items=Obj, selected=1, container=w, + handler=hist.reactive) +glabel(text="Escolha a regra para número de classes:", container=w) +nclass <- gcombobox(items=Nclass, selected=1, container=w, + handler=hist.reactive) + +w <- gwindow("Histograma") +g <- gframe(text="Escolha o conjunto de dados:", container=w) +obj <- gcombobox(items=Obj, selected=1, container=g, + handler=hist.reactive) +g <- gframe(text="Escolha a regra para número de classes:", container=w) +nclass <- gcombobox(items=Nclass, selected=1, container=g, + handler=hist.reactive) diff --git a/gWidgets/hist_Select.gif b/gWidgets/hist_Select.gif new file mode 100644 index 0000000000000000000000000000000000000000..bf2e22ca611442a76fe53e2dc37f23e12128cefd Binary files /dev/null and b/gWidgets/hist_Select.gif differ diff --git a/gWidgets/hist_Slider.R b/gWidgets/hist_Slider.R new file mode 100644 index 0000000000000000000000000000000000000000..ddf8491c79e7fedad588809face48816f5e424e5 --- /dev/null +++ b/gWidgets/hist_Slider.R @@ -0,0 +1,25 @@ +## Deslizador (gslider) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip + +## Extremos com amplitude estendida em 5%. +a <- extendrange(x, f=0.05) + +hist.reactive <- function(...){ + bks <- seq(a[1], a[2], length.out=svalue(nclass)+1) + hist(x, + breaks=bks, + main=NULL, + col="#008A8A", + ylab="Frequência absoluta", + xlab="Precipitação") +} + +w <- gwindow("Histograma") +g <- gframe(text="Escolha o número de classes:", container=w) +nclass <- gslider(from=1, to=30, by=1, value=10, + container=g, handler=hist.reactive) diff --git a/gWidgets/hist_Slider.gif b/gWidgets/hist_Slider.gif new file mode 100644 index 0000000000000000000000000000000000000000..d49873a8d6908d78f101146498184ed0505d6202 Binary files /dev/null and b/gWidgets/hist_Slider.gif differ diff --git a/gWidgets/hist_Text.R b/gWidgets/hist_Text.R new file mode 100644 index 0000000000000000000000000000000000000000..719eecf305677f05bcd9b4f70f85754d31d7e24a --- /dev/null +++ b/gWidgets/hist_Text.R @@ -0,0 +1,28 @@ +## Entrada de texto (gedit) + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +x <- precip +ht <- hist(x) + +hist.reactive <- function(...){ + plot(ht, col="#006666", + ylab="Frequência absoluta", + xlab="Precipitação", + main=svalue(main), + sub=svalue(sub)) +} + +w <- gwindow("Histograma") +g <- gframe(text="Texto para o tÃtulo:", container=w) +main <- gedit(text=NULL, + initial.msg="Insira e pressione Enter", + coerce.with="as.character", + container=g, handler=hist.reactive) +g <- gframe(text="Texto para o subtÃtulo:", container=w) +sub <- gedit(text=NULL, + initial.msg="Insira e pressione Enter", + coerce.with="as.character", + container=g, handler=hist.reactive) diff --git a/gWidgets/hist_Text.gif b/gWidgets/hist_Text.gif new file mode 100644 index 0000000000000000000000000000000000000000..3f27cbc811ba59055caf3e42b81e6f5ee958755e Binary files /dev/null and b/gWidgets/hist_Text.gif differ diff --git a/gWidgets/lancaNotas.R b/gWidgets/lancaNotas.R new file mode 100644 index 0000000000000000000000000000000000000000..a10f2859b6d2f11349f73c51418ff42fef96edd1 --- /dev/null +++ b/gWidgets/lancaNotas.R @@ -0,0 +1,71 @@ +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +##----------------------------------------------------------------------------- + +## format(da$nome, width=max(nchar(da$nome))) +cform <- function(x){ + if(is.numeric(x)){ + x <- round(x, digits=2) + } + format(as.character(x), width=max(nchar(x))) +} + +## Gerando dados. +da <- data.frame(grr=sample(100:200, size=7)) +da$nome <- sample(colors(), size=length(da$grr)) +da$nota <- NA +da <- da[order(da$grr),] + +txt <- apply(sapply(da[,1:2], cform), 1, paste, collapse=" ") +w <- gwindow("Lançar notas", visible=FALSE, width=400) +g <- gpanedgroup(horizontal=FALSE, container=w) +glabel(text="Busque pelo GRR:", container=g) +grr <- gedit(text="", initial.msg="1234", + container=g) +grr[] <- da$grr +glabel(text="Atribua nota:", container=g) +nota <- gedit(text="", initial.msg="Nota", container=g, + enabled=FALSE) +enabled(nota) <- FALSE +glabel(text="Alunos sem nota:", container=g) +outp <- gtext(text=txt[is.na(da$nota)], + container=g) +size(outp) <- c(300,100) +enabled(outp) <- FALSE +visible(w) <- TRUE +addHandlerKeystroke(obj=grr, + handler=function(h, ...){ + enabled(outp) <- TRUE + i <- grepl(pattern=paste0("^", svalue(grr)), + x=da$grr) + svalue(outp) <- txt[i & is.na(da$nota)] + if(sum(i)==1){ + enabled(nota) <- TRUE + } else { + enabled(nota) <- FALSE + } + }) +addHandlerChanged(nota, + function(h, ...){ + blockHandler(grr) + i <- grep(pattern=paste0("^", svalue(grr)), + x=da$grr) + y <- eval(expr=parse(text=svalue(nota))) + da[i,]$nota <<- as.numeric(y) + txt[i] <<- paste(txt[i], y) + enabled(nota) <- FALSE + enabled(outp) <- FALSE + svalue(nota) <- "" + unblockHandler(grr) + svalue(grr) <- "" + svalue(outp) <- txt + }) + +da + +## apropos("^g", mode="function") +## grep(x=ls("package:gWidgets"), pattern="^g", value=TRUE) + +## eval(expr=parse(text="2+4")) diff --git a/gWidgets/poderNormal.R b/gWidgets/poderNormal.R new file mode 100644 index 0000000000000000000000000000000000000000..7e36cb7ff709a0b825481d8c75fb9301876649d3 --- /dev/null +++ b/gWidgets/poderNormal.R @@ -0,0 +1,145 @@ +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +## library(RGtk2) +## library(gWidgets) +## library(gWidgetsRGtk2) +## options(guiToolkit="RGtk2") + +##----------------------------------------------------------------------------- + +## Faz polÃgono para destacar região de não rejeição de H0. +pol <- function(m1, s, lim, + col=rgb(0.5,0.5,0.5,0.5), border=NA, ...){ + xx <- seq(lim[1], lim[2], + length.out=floor(100*diff(lim)/diff(par()$usr[1:2]))) + yy <- dnorm(xx, m1, s) + xx <- c(lim[1], xx, lim[2]) + yy <- c(0, yy, 0) + polygon(x=xx, y=yy, col=col, border=border, ...) +} + +## Faz o polÃgono nas caudas, regiões de rejeição de H0. +cau <- function(m0, s, lim, ...){ + parlim <- par()$usr[1:2] + reglim <- lim + ## Left. + lim <- c(parlim[1], reglim[1]) + pol(m0, s, lim, ...) + ## Right. + lim <- c(reglim[2], parlim[2]) + pol(m0, s, lim, ...) +} + +## Calcula o poder do teste. +power <- function(m1, s, z){ + p <- pnorm(z, m1, s) + diff(p) +} +power <- Vectorize(FUN=power, vectorize.args="m1") + +## Faz a figura. + +## dofig <- function(m0=0, m=0.5, s=1, n=10, alpha=0.9, delta=2, +## xlim=m0+c(-1,1)*delta*s, +## fillcenter=rgb(0.5,0.5,0.5,0.5), +## filltails=rgb(0.95,0.15,0.15,0.75)){ +dofig <- function(...){ + m0 <- svalue(m0) + m <- svalue(m) + s <- svalue(s) + n <- svalue(n) + alpha <- svalue(alpha) + ## delta <- svalue(delta) + xlim <- m0+c(-1,1)*svalue(r) + fillcenter <- rgb(0.5,0.5,0.5,0.5) + filltails <- rgb(0.95,0.15,0.15,0.75) + ## m0 <- 0; m <- 0.5; s <- 1; n <- 20; alpha <- 0.8; delta <- 2 + ## fillcenter <- rgb(0.5,0.5,0.5,0.5) + ## filltails <- rgb(0.95,0.15,0.15,0.75) + sm <- s/sqrt(n) + p <- c(0, alpha)+(1-alpha)/2 + z <- qnorm(p, mean=m0, sd=sm) + ## xlim <- m0+c(-1,1)*delta*s + mvals <- seq(xlim[1], xlim[2], length.out=100) + pwvals <- 1-power(mvals, s=sm, z=z) + par(mfrow=c(2,1), mar=c(3,4.4,2,2.5)) + curve(dnorm(x, m0, sm), xlim[1], xlim[2], + ## xaxt="n", yaxt="n", + xlab=NA, ylab=NA) + axis(side=1, at=c(m0, m), + labels=expression(mu[0], mu), + tick=FALSE, line=1.25) + cau(m0, sm, lim=z, col=filltails) + pol(m=m, s=sm, lim=z) + curve(dnorm(x, m, sm), add=TRUE, lty=2) + segments(x0=m0, x1=m0, + y0=0, y1=dnorm(m0, m0, sm)) + segments(x0=m, x1=m, + y0=0, y1=dnorm(m, m, sm), + lty=2) + title(main=expression(H[0]*":"~mu==mu[0])) + legend(y=sum(c(0,1.15)*par()$usr[3:4]), + x=sum(c(0.1,0.79)*par()$usr[1:2]), + xpd=TRUE, bty="n", fill=fillcenter, + legend=sprintf("%0.4f", power(m1=m, s=sm, z=z))) + plot(pwvals~mvals, ylim=c(0,1), type="l", + xaxt="n", yaxt="n", + xlab=NA, ylab=NA) + pw <- 1-power(m, s=sm, z=z) + abline(v=0, h=1-alpha, lty=3) + abline(v=m, h=pw, lty=2) + axis(side=1, at=c(m0, m), + labels=expression(mu[0], mu), tick=TRUE) + axis(side=2, at=pw, + labels=sprintf("%0.4f", pw), las=2) + axis(side=4) +} + +##----------------------------------------------------------------------------- + +w <- gwindow(title="Poder do teste", visible=FALSE) +g <- gpanedgroup(horizontal=FALSE, container=w) +##-------------------------------------------- +gfa <- gframe(text="NÃvel de significância do teste:", container=g) +alpha <- gspinbutton(from=0.8, to=0.99, by=0.01, + handler=dofig, + container=gfa) +svalue(alpha) <- 0.9 +##-------------------------------------------- +gfn <- gframe(text="Tamanho da amostra de X (n):", container=g) +n <- gspinbutton(from=3, to=50, by=1, + handler=dofig, + container=gfn) +svalue(n) <- 10 +##-------------------------------------------- +gfm0 <- gframe(text="Média de X sob H0 (mu0):", container=g) +m0 <- gspinbutton(from=-2, to=2, by=0.1, + handler=dofig, + container=gfm0) +svalue(m0) <- 0 +##-------------------------------------------- +gfs <- gframe(text="Desvio-padrão de X (s):", container=g) +s <- gslider(from=0.1, to=6, by=0.05, + handler=dofig, + container=gfs) +svalue(s) <- 1 +##-------------------------------------------- +gfm <- gframe(text="Média de X (mu):", container=g) +m <- gslider(from=svalue(m0)-10*svalue(s)/sqrt(svalue(n)), + to=svalue(m0)+10*svalue(s)/sqrt(svalue(n)), + length.out=50, + handler=dofig, + container=gfm) +svalue(m) <- svalue(m0) +##-------------------------------------------- +gfr <- gframe(text="Fator de amplitude de eixo:", container=g) +r <- gedit(text=5, coerce.with=as.numeric, + handler=dofig, + container=gfr) +svalue(r) <- 5 +##-------------------------------------------- +visible(w) <- TRUE + + diff --git a/gWidgets/probDistributions.R b/gWidgets/probDistributions.R new file mode 100644 index 0000000000000000000000000000000000000000..68bab9f117ed83dc2bc0505adaa303d5ef5edd8d --- /dev/null +++ b/gWidgets/probDistributions.R @@ -0,0 +1,79 @@ +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +##---------------------------------------------------------------------- + +selDist.pdf <- function(...){ + switch(svalue(dist), + "Normal"=norm.pdf(), + "Exponencial"=exp.pdf(), + "Poisson"=pois.pdf() + ) +} +dists <- c("Normal", "Exponencial", "Poisson") + +##---------------------------------------------------------------------- +## Abre outra janela. + +norm.pdf <- function(){ + f <- function(...){ + curve(dnorm(x, mean=svalue(m), sd=svalue(s)), + from=-4, to=4, ylim=c(0,0.6), + xlab="x", ylab="f(x)") + } + w2 <- gwindow(title="Distribuição Normal", + width=500, parent=w1) + g <- ggroup(container=w2, horizontal=FALSE) + glabel(text="Média", container=g) + m <- gslider(from=-1, to=1, by=0.1, value=0, handler=f, container=g) + glabel(text="Variância", container=g) + s <- gslider(from=0.1, to=2, by=0.1, value=1, handler=f, + container=g) + gbutton(text="Fechar", container=g, + handler=function(...){ + dispose(w2) + }) +} + +exp.pdf <- function(){ + f <- function(...){ + curve(dexp(x, rate=svalue(r)), + from=0, to=5, ylim=c(0,1.6), + xlab="x", ylab="f(x)") + } + w2 <- gwindow(title="Distribuição exponencial", + width=500, parent=w1) + g <- ggroup(container=w2, horizontal=FALSE) + glabel(text="Taxa", container=g) + r <- gslider(from=0, to=5, by=0.1, value=1, handler=f, container=g) + gbutton(text="Fechar", container=g, + handler=function(...){ + dispose(w2) + }) +} + +pois.pdf <- function(){ + f <- function(...){ + x <- 0:30 + px <- dpois(x, lambda=svalue(l)) + plot(px~x, type="h", ylim=c(0,0.25), + xlab="x", ylab="p(x)") + points(x=x, y=px, pch=19, cex=0.8) + } + w2 <- gwindow(title="Distribuição de Poisson", + width=500, parent=w1) + g <- ggroup(container=w2, horizontal=FALSE) + glabel(text="Média", container=g) + l <- gslider(from=0, to=20, by=0.5, value=5, handler=f, container=g) + gbutton(text="Fechar", container=g, + handler=function(...){ + dispose(w2) + }) +} + +w1 <- gwindow(title="Distribuições de probabilidade", + width=300) +g1 <- gframe(text="Escolha a distribuição.", container=w1) +dist <- gradio(items=dists, selected=0L, container=g1, + handler=selDist.pdf) diff --git a/gWidgets/testHipFlipCoin.R b/gWidgets/testHipFlipCoin.R new file mode 100644 index 0000000000000000000000000000000000000000..54e5b5ccf025ebf97da679f8bd013713f0e1f081 --- /dev/null +++ b/gWidgets/testHipFlipCoin.R @@ -0,0 +1,173 @@ +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +##---------------------------------------------------------------------- + +## Vetor vazio. +x <- integer() + +## Simula o número de trocas ao lançar n vezes uma moeda equilibrada. +moeda <- function(n){ + sum(abs(diff(rbinom(n, 1, 0.5)))) +} + +seqnlanc <- function(...){ + ## seqx <- paste(x, collapse="") + ## seqx <- rev(paste( + ## strwrap(x=paste(x, collapse=" "), width=20), "\n")) + seqx <- rev(gsub(x=strwrap(x=paste(x, collapse=" "), width=20), + pattern="\\D", replacement="")) + nx <- length(x) + fmt <- sprintf("Número de lançamentos: %i", nx) + return(list(seqx=seqx, nx=nx, fmt=fmt)) +} + +cara <- function(...){ + x <<- c(x, 1L) + svalue(nlanc) <- seqnlanc()$fmt + svalue(seqx) <- seqnlanc()$seqx +} +coro <- function(...){ + x <<- c(x, 0L) + svalue(nlanc) <- seqnlanc()$fmt + svalue(seqx) <- seqnlanc()$seqx +} + +simul <- function(...){ + ## Número de simulações. + N <- svalue(nsimul) + ## Número de lançamentos. + n <- length(x) + ## Número de caras. + k <- sum(x) + ## Número de trocas de face. + o <- sum(abs(diff(x))) + ## Faz várias execuções do experimento aleatório. + r <- replicate(N, moeda(n)) + ## P-valor bilateral empÃrico. + p <- min(c(2*min(c(sum(r<=o), sum(r>=o)))/N, 1)) + ## Lista com todos os elementos. + return(list(n=n, k=k, o=o, r=r, p=p, x=x, N=N)) +} + +plotresults <- function(...){ + with(simul(),{ + if(n<=20){ + ## stop("Pro favor, lance no mÃnimo 30 vezes.") + gmessage(message="Lance pelo menos 20 vezes.", + title="Atenção!") + ## stopifnot(n>10) + } else { + par(mar=c(5,4,3,2), family="Palatino") + switch(ifelse(svalue(showhow)=="123", "triple", "single"), + "triple"=layout(matrix(c(1,2,1,3), 2, 2)), + "single"=layout(1)) + bks <- seq(min(c(r,o)), max(c(r,o))+1, by=1)-0.5 + ht <- hist(r, breaks=bks, plot=FALSE) + if(svalue(teorico)){ + px <- dbinom(x=ht$mids, size=n-1, prob=0.5) + sfun0 <- stepfun(ht$mids, cumsum(c(0,px)), f=0) + } + if(svalue(showhow)%in%c("1","123")){ + plot(ht$mids, ht$density, type="h", lwd=2, + ylim=c(0, 1.05*max(ht$density)), + xlab=sprintf( + "Número de trocas em %i lançamentos", n), + ylab="Probabilidade", + sub=sprintf("%i simulações", N)) + if(svalue(teorico)){ + points(ht$mids+0.1, px, type="h", col="blue", lwd=2) + pb <- 2*pbinom(q=min(c(o, n-o-1)), size=n-1, p=0.5) + mtext(side=3, line=0, col="blue", + text=sprintf( + "P-valor bilateral teórico: %0.4f", pb)) + } + abline(v=o, col=2) + text(x=o, y=par()$usr[4], + label="EstatÃstica observada", + srt=90, adj=c(1.25,-0.25)) + mtext(side=3, line=1, + text=sprintf( + "P-valor bilateral empÃrico: %0.4f", p)) + mtext(side=3, line=2, + text=sprintf( + "Trocas observadas: %i\t Número de caras: %i", + o, k)) + } + if(svalue(showhow)%in%c("2","123")){ + plot(cumsum(x)/seq_along(x), type="l", ylim=c(0,1), + ylab="Frequência de face cara", + xlab="Número do lançamento") + abline(h=0.5, lty=2) + } + if(svalue(showhow)%in%c("3","123")){ + plot(ecdf(r), verticals=FALSE, cex=NA, + main=NULL, xlim=range(bks), + xlab=sprintf( + "Número de trocas em %i lançamentos", n), + ylab="Probabilidade acumulada", + sub=sprintf("%i simulações", N)) + if(svalue(teorico)){ + plot(x=sfun0, xval=ht$mids, verticals=FALSE, + add=TRUE, col="blue") + } + ## abline(h=seq(0.05, 0.95, by=0.05), + ## lty=2, col="gray50") + abline(v=o, col=2) + text(x=o, y=par()$usr[4], + label="EstatÃstica observada", + srt=90, adj=c(1.25,-0.25)) + } + } + }) +} + +##----------------------------------------------------------------------------- +## Construção da interface. + +w <- gwindow(title="Lançar moedas", visible=FALSE) +g <- ggroup(horizontal=FALSE, container=w) +lyt <- glayout(container=g, spacing=2) +lyt[1,1] <- (caraB <- + gbutton(text="Cara", + handler=cara, + container=lyt)) +lyt[1,2] <- (coroB <- + gbutton(text="Coroa", + handler=coro, + container=lyt)) +lyt[2,1:2, expand=TRUE] <- (nlanc <- + glabel(text="Número de lançamentos:", + container=lyt)) +glabel(text="Sequência de valores:", + container=g) +seqx <- gtext(text="", container=g, + width=200, height=120) +a <- gexpandgroup(text="Avançado", container=g, + horizontal=FALSE) +teorico <- gcheckbox(text="Mostrar distribuição teórica.", + checked=FALSE, action=plotresults, + container=a) +glabel(text="Número de simulações:", container=a) +nsimul <- gradio(items=c(100,500,1000,5000,10000), + horizontal=TRUE, selected=4, + action=simul, container=a) +glabel(text="Disposição e gráficos:", container=a) +showhow <- gradio(items=c("1","2","3","123"), + horizontal=TRUE, selected=4, + action=plotresults, container=a) +lyu <- glayout(container=g, spacing=2) +lyu[1,1, expand=TRUE] <- (results <- + gbutton(text="Processar!", + handler=plotresults, container=lyu)) +lyu[2,1, expand=TRUE] <- (new <- + gbutton(text="Limpar e recomeçar!", container=lyu, + handler=function(...){ + x <<- integer() + svalue(nlanc) <- "Número de lançamentos:" + svalue(seqx) <- "" + })) +visible(w) <- TRUE + +##---------------------------------------------------------------------- diff --git a/gWidgets/transform.R b/gWidgets/transform.R new file mode 100644 index 0000000000000000000000000000000000000000..60d4f091abc6eab34ddeeeab0f28a4ddb0c1814a --- /dev/null +++ b/gWidgets/transform.R @@ -0,0 +1,75 @@ +##====================================================================== +## Interface para exibição do gráfico de dispersão das variáveis dist e +## speed do conjunto data(cars), aplicando transformações nas variáveis +## e ajustando uma regressão linear simples. São abordados os seguintes +## widgets: +## * Listbox +## * Checkbox +##====================================================================== + +##====================================================================== +## Definições da sessão. + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +## Variáveis e tranformações consideradas na aplicação +x <- cars$speed +y <- cars$dist +trans <- c("Identidade", "Quadrado", "RaizQuadrada", "Log10") + +##---------------------------------------------------------------------- +## Função reativa. + +transformation <- function(...) { + ## Transformando as variáveis + tx <- svalue(tx) + ty <- svalue(ty) + x <- switch(tx, + Identidade = x, + Quadrado = x^2, + RaizQuadrada = sqrt(x), + Log10 = log10(x) + ) + y <- switch(ty, + Identidade = y, + Quadrado = y^2, + RaizQuadrada = sqrt(y), + Log10 = log10(y) + ) + ## Protegendo a função devido a primeira seleção + if(is.null(x)){ x <- cars$speed; tx <- "Identidade"} + if(is.null(y)){ y <- cars$dist; ty <- "Identidade"} + ## Exibindo graficamente + plot(y ~ x, pch=20, main = "Gráfico de Dispersão", + xlab = paste(tx, "de X", sep=" "), + ylab = paste(ty, "de Y", sep=" ")) + m0 <- lm(y ~ x) + r <- summary(m0)$r.squared + c <- round(cor(x, y), 3) + msg <- sprintf("R²: %0.3f \nCor: %0.3f", r, c) + if(svalue(reg)){ + abline(coef(m0), col=4) + mtext(text = msg, side=3, cex=0.9, col=4, + adj=0.05, line=-2) + } +} + +##---------------------------------------------------------------------- +## Criando a interface. + +win <- gwindow("Transformação de Variáveis") + +tx <- gtable(trans, cont=win, height=100, + handler = transformation) +names(tx) <- "Tranformação em X" + +ty <- gtable(trans, cont=win, height=100, + handler = transformation) +names(ty) <- "Tranformação em Y" + +reg <- gcheckbox("Ajuste Regressão Linear", cont=win, + handler = transformation) + +##---------------------------------------------------------------------- diff --git a/gWidgets/widgets.R b/gWidgets/widgets.R new file mode 100644 index 0000000000000000000000000000000000000000..5a6900dd3e14bf3c3f4b42f78331b189da66b78e --- /dev/null +++ b/gWidgets/widgets.R @@ -0,0 +1,57 @@ +## Coleção de widgets. + +require(gWidgets) +require(gWidgetstcltk) +options(guiToolkit="tcltk") + +w <- gwindow(title="Coleção de widgets", width=600, height=500, visible=FALSE) +gg <- gpanedgroup(horizontal=TRUE, container=w) +gg1 <- ggroup(horizontal=FALSE, container=gg) +gg2 <- ggroup(horizontal=FALSE, container=gg) +svalue(gg) <- 0.5 + +gg1 <- gpanedgroup(horizontal=FALSE, container=gg1) +gg2 <- gpanedgroup(horizontal=FALSE, container=gg2) + +gf <- gframe(text="gbutton", container=gg1) +gbutton(text="Ok!", container=gf) + +gf <- gframe(text="gspinbutton", container=gg1) +gspinbutton(from=0, to=10, by=1, value=4, container=gf) + +gf <- gframe(text="gslider", container=gg1) +gslider(from=0, to=10, by=1, value=4, container=gf) + +gf <- gframe(text="gedit", container=gg1) +gedit(initial.msg="Mensagem inicial", container=gf) + +gf <- gframe(text="gtext", container=gg1) +gtext(text="Texto inicial editável", container=gf) + +gf <- gframe(text="gcheckbox", container=gg2) +gcheckbox(text="Marcar", checked=TRUE, container=gf) + +gf <- gframe(text="gcheckboxgroup", container=gg2) +gcheckboxgroup(items=c("Item 1", "Item 2", "Item 3"), + checked=c(TRUE,FALSE,TRUE), + container=gf) + +gf <- gframe(text="gradio", container=gg2) +gradio(items=c("Opção 1","Opção 2","Opção 3"), + selected=1, container=gf) + +gf <- gframe(text="gcombobox", container=gg2) +gcombobox(items=c("Opção 1","Opção 2","Opção 3"), + selected=1, container=gf, editable=TRUE) + +gf <- gframe(text="gdroplist", container=gg2) +gdroplist(items=c("Opção 1","Opção 2","Opção 3"), + selected=1, container=gf, editable=TRUE) + +gf <- gframe(text="gtable", container=gg2) +gtable(items=c("Opção 1","Opção 2","Opção 3"), + selected=1, container=gf) + +visible(w) <- TRUE + +## help(gslider, h="html")