Adiciona aplicações de gWidgets do iguir1.

gWidgets/density.R

+##----------------------------------------------------------------------
+## 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))
+
+##----------------------------------------------------------------------

gWidgets/hist.R

+##-----------------------------------------------------------------------------
+## 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))
+
+##-----------------------------------------------------------------------------

gWidgets/hist_Button.R

+## 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)

gWidgets/hist_Checkbox.R

+## 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)

gWidgets/hist_Checkboxgroup.R

+## 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)

gWidgets/hist_Numeric.R

+## 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

gWidgets/hist_Radio.R

+## 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)

gWidgets/hist_Select.R

+## 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)

gWidgets/hist_Slider.R

+## 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)

gWidgets/hist_Text.R

+## 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)

gWidgets/lancaNotas.R

+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"))

gWidgets/poderNormal.R

+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
+
+