Commit 9cc941d8 authored by Walmes Marques Zeviani's avatar Walmes Marques Zeviani
Browse files

Merge branch 'issue#8' into 'master'

Issue#8

Esse ramo traz:
  - aplicações em `rpanel` do iguir1;
  - aplicações em `gWidgets` do iguir1;

See merge request !8
parents 8c9cfe6d 86253497
##----------------------------------------------------------------------
## 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))
##----------------------------------------------------------------------
##-----------------------------------------------------------------------------
## 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))
##-----------------------------------------------------------------------------
## 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)
## 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)
## 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)
## 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
## 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)
## 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)
## 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)
## 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)
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"))
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