Commit ee1ad05d authored by Walmes Marques Zeviani's avatar Walmes Marques Zeviani
Browse files

Adiciona aplicações em rpanel.

parent 8c9cfe6d
## Botão de ação (rp.button)
require(rpanel)
x <- precip
ht <- hist(x)
hist.reactive <- function(input){
col <- sample(colors(), size=1)
plot(ht, main=NULL,
ylab="Frequência absoluta", xlab="Precipitação",
col=col, sub=col)
return(input)
}
panel <- rp.control(title="Histograma")
rp.button(panel=panel,
title="Nova cor!",
action=hist.reactive)
## Caixa de seleção (rp.checkbox)
require(rpanel)
x <- precip
ht <- hist(x)
col <- rep("#3366CC", length(ht$counts))
hist.reactive <- function(input){
if(input$modal){
col[which.max(ht$counts)] <- "#142952"
}
plot(ht, col=col, main=NULL,
ylab="Frequência absoluta",
xlab="Precipitação")
if(input$rg){
rug(x)
}
return(input)
}
panel <- rp.control(title="Histograma")
rp.checkbox(panel=panel, variable=rg,
title="Marcar sobre eixo com os valores?",
initval=FALSE,
action=hist.reactive)
rp.checkbox(panel=panel, variable=modal,
title="Destacal a classe modal?",
initval=FALSE,
action=hist.reactive)
## Caixa de seleção múltipla (rp.checkbox)
require(rpanel)
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(input){
seqcol <- colorRampPalette(cols2[input$colors])
plot(ht, col=seqcol(nc),
main=NULL,
ylab="Frequência absoluta",
xlab="Precipitação")
return(input)
}
panel <- rp.control(title="Histograma")
rp.checkbox(panel=panel, variable=colors,
title="Escolha as cores para interpolar:",
labels=names(cols2),
initval=c(TRUE, is.na(cols2)[-1]),
action=hist.reactive)
## Entrada numérica (rp.numeric)
require(rpanel)
x <- precip
ht <- hist(x)
hist.reactive <- function(input){
m <- input$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=input$cexaxis)
axis(side=2, cex.axis=input$cexaxis)
title(ylab="Frequência absoluta",
xlab="Precipitação",
line=input$line)
return(input)
}
panel <- rp.control(title="Histograma")
rp.doublebutton(panel=panel, variable=mar,
title="Tamanho das margens:",
initval=5, range=c(3, 7), step=0.5,
action=hist.reactive)
rp.doublebutton(panel=panel, variable=cexaxis,
title="Tamanho do texto dos eixos:",
initval=1, range=c(0.5, 2), step=0.1,
action=hist.reactive)
rp.doublebutton(panel=panel, variable=line,
title="Distância dos rótulos dos eixos:",
initval=3, range=c(1, 4), step=0.1,
action=hist.reactive)
## Múltipla escolha (rp.radiogroup)
require(rpanel)
x <- precip
ht <- hist(x)
hist.reactive <- function(input){
plot(ht,
col=input$col,
main=NULL,
ylab="Frequência absoluta",
xlab="Precipitação")
return(input)
}
choices <- c(Turquesa="#00CC99",
Azul="#0066FF",
Rosa="#FF3399",
Laranja="#FF6600",
Roxo="#660066",
"Verde limão"="#99FF33")
panel <- rp.control(title="Histograma")
rp.radiogroup(panel=panel, variable=col,
title="Escolha a cor para as barras:",
vals=choices, labels=names(choices),
action=hist.reactive)
## Caixa de seleção (rp.listbox)
require(rpanel)
nclass <- c("Sturges", "Scott", "Freedman-Diaconis")
obj <- c("precip","rivers","islands")
hist.reactive <- function(input){
L <- switch(input$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=input$nclass,
col="#8F0047",
main=NULL,
ylab="Frequência absoluta",
xlab=L$xlab)
rug(L$x)
return(input)
}
panel <- rp.control(title="Histograma")
rp.combo(panel=panel, variable=obj,
prompt="Escolha o conjunto de dados:",
vals=obj, initval=obj[1],
action=hist.reactive)
rp.combo(panel=panel, variable=nclass,
prompt="Escolha a regra para número de classes:",
vals=nclass, initval=nclass[1],
action=hist.reactive)
panel <- rp.control(title="Histograma")
rp.listbox(panel=panel, variable=obj,
title="Escolha o conjunto de dados:",
vals=obj, initval=obj[1],
action=hist.reactive)
rp.listbox(panel=panel, variable=nclass,
title="Escolha a regra para número de classes:",
vals=nclass, initval=nclass[1],
action=hist.reactive)
## Caixas de seleção (rp.listbox e rp.radiogroup)
require(rpanel)
fml <- names(X11Fonts())
fnt <- c("plain"=1, "bold"=2, "italic"=3, "bold-italic"=4)
x <- precip
ht <- hist(x)
hist.reactive <- function(input){
f <- as.integer(input$fnt)
plot(ht,
family=input$fml,
font=as.integer(input$fnt),
col="#FF9200",
main=NULL,
ylab="Frequência absoluta",
xlab="Precipitação")
return(input)
}
panel <- rp.control(title="Histograma")
rp.listbox(panel=panel, variable=fml,
title="Escolha o tipo de fonte:",
vals=fml, initval=fml[1],
action=hist.reactive)
rp.radiogroup(panel=panel, variable=fnt,
title="Escolha o estilo de fonte:",
vals=fnt, initval=fnt[1],
labels=names(fnt),
action=hist.reactive)
## Deslizador (rp.slider)
require(rpanel)
x <- precip
## Extremos com amplitude estendida em 5%.
a <- extendrange(x, f=0.05)
hist.reactive <- function(input){
bks <- seq(a[1], a[2], length.out=input$nclass+1)
hist(x,
breaks=bks,
main=NULL,
col="#008A8A",
ylab="Frequência absoluta",
xlab="Precipitação")
return(input)
}
panel <- rp.control(title="Histograma")
rp.slider(panel=panel, variable=nclass,
title="Escolha o número de classes:",
from=1, to=30, resolution=1, initval=10,
action=hist.reactive)
## Entrada de texto (rp.textentry)
require(rpanel)
x <- precip
ht <- hist(x)
hist.reactive <- function(input){
plot(ht, col="#006666",
ylab="Frequência absoluta",
xlab="Precipitação",
main=input$main,
sub=input$sub)
return(input)
}
panel <- rp.control(title="Histograma")
rp.textentry(panel=panel, variable=main,
labels="Texto para o título:",
initval="",
action=hist.reactive)
rp.textentry(panel=panel, variable=sub,
labels="Texto para o subtítulo:",
initval="",
action=hist.reactive)
require(rpanel)
require(plyr)
require(latticeExtra)
## require(car)
require(alr3)
require(wzRfun)
##----------------------------------------------------------------------
url <- "http://westfall.ba.ttu.edu/isqs5349/Rdata/turtles.txt"
tur <- read.table(url, header=TRUE, sep="\t")
str(tur)
xtabs(~gender, tur)
tur$Gender <- factor(tur$gender)
form <- c("null"=.~1,
"gend"=.~Gender,
"leng"=.~length,
"gend+leng"=.~Gender+length,
"gend*leng"=.~Gender*length)
m1 <- lm(height~Gender*length, data=tur)
p1 <- xyplot(height~length, groups=Gender, data=tur,
ylab="Altura", xlab="Comprimento")
p1
pred <- ddply(tur, .(Gender), summarise,
length=seq(min(tur$length), max(tur$length), l=20))
draw.model <- function(panel){
m3 <- update(m1, as.formula(form[[panel$f]]))
pred <- cbind(pred, predict(m3, newdata=pred, interval="confidence"))
p2 <- xyplot(fit~length, groups=Gender, data=pred, type="l",
ly=pred$lwr, uy=pred$upr, cty="bands", alpha=0.5,
prepanel=prepanel.cbH, panel=panel.superpose,
panel.groups=panel.cbH)
print(p1+as.layer(p2, under=TRUE))
panel
}
panel <- rp.control()
rp.listbox(panel, variable=f, vals=names(form), action=draw.model)
##----------------------------------------------------------------------
str(sleep1)
## help(sleep1, h="html")
## Danger Index.
sleep1$D <- factor(sleep1$D)
sleep1$lbw <- log(sleep1$BodyWt)
xyplot(TS~lbw|D, data=sleep1)
xyplot(TS~lbw|D, data=sleep1, type=c("p","r"))
##-----------------------------------------------------------------------------
## Ajuste do modelo.
m1 <- lm(log(TS)~D*lbw, data=sleep1)
## Diagnóstico.
par(mfrow=c(2,2)); plot(m1); layout(1)
##-----------------------------------------------------------------------------
## Estimativas por grupo.
## R² com SQT corrigida para média.
summary(m1)
form <- c("null"=.~1,
"D"=.~D,
"lbw"=.~lbw,
"D+lbw"=.~D+lbw,
"D*lbw"=.~D*lbw)
pred <- ddply(sleep1, .(D), summarise,
lbw=seq(min(lbw), max(lbw), l=20)
## lbw=extendseq(lbw, l=12)
)
draw.model <- function(panel){
m3 <- update(m1, as.formula(form[[panel$f]]))
pred <- cbind(pred,
predict(m3, newdata=pred, interval="confidence"))
p1 <- xyplot(log(TS)~lbw|D, data=sleep1)
p2 <- xyplot(fit~lbw|D, data=pred, type="l",
ly=pred$lwr, uy=pred$upr, cty="bands", alpha=0.25,
prepanel=prepanel.cbH,
panel=panel.cbH)
print(p1+as.layer(p2, under=TRUE))
panel
}
panel <- rp.control()
rp.listbox(panel, variable=f, vals=names(form), action=draw.model,
title="Select a model")
require(rpanel)
rp.density <- function(x){
draw.density <- function(panel){
## Plot density curve and add the rugs.
n <- length(na.omit(panel$x))
aux <- density(panel$x, width=panel$width, kernel=panel$kernel)
plot(aux, main=NA)
rug(panel$x)
## The interval.
arrows(panel$xc-0.5*panel$width, 0,
panel$xc+0.5*panel$width, 0,
length=0.1, code=3, angle=90, col=2)
## Line at center.
yc <- approx(aux$x, aux$y, xout=panel$xc)
arrows(panel$xc, 0, panel$xc, yc$y, length=0.1, col=2)
## Density for a single point.
d <- density(panel$xc, width=panel$width,
kernel=panel$kernel, n=128)
lines(d$x, d$y/n, col=2)
switch(panel$points,
"points"={
i <- findInterval(panel$x, vec=d$x[c(1,128)])
## i <- findInterval(panel$x, vec=range(d$x))
xin <- panel$x[i==1L]
yin <- approx(d$x, d$y/n, xout=xin)
points(yin$x, yin$y, pch=19, cex=0.5, col=2)
},
"segments"={
i <- findInterval(panel$x, vec=d$x[c(1,128)])
xin <- panel$x[i==1L]
yin <- approx(d$x, d$y/n, xout=xin)
segments(yin$x, 0, yin$x, yin$y, col=2)
},
"none"={
NULL
}
)
panel
}
## Initialization.
init <- density(x)
init$er <- extendrange(x, f=0.1)
init$kernels <- eval(formals(density.default)$kernel)
init$w <- 4*init$bw ## For gaussian.
## Panels.
panel <- rp.control(x=x)
rp.slider(panel, variable=width,
from=init$w*0.05, to=init$w*3, initval=init$w,
showvalue=TRUE, action=draw.density, title="Width")
rp.slider(panel, variable=xc,
from=init$er[1], to=init$er[2],
initval=mean(x, na.rm=TRUE),
showvalue=TRUE, action=draw.density, title="Center")
rp.radiogroup(panel, variable=kernel, vals=init$kernels,
action=draw.density, title="Kernel function")
rp.radiogroup(panel, variable=points,
vals=c("points","segments","none"),
action=draw.density, title="Density on points")
rp.do(panel, action=draw.density)
}
x <- rnorm(30)
x11()
rp.density(precip)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment