Arquivo

Posts Tagged ‘levelplot’

Legenda e contornos em gráficos de nível

Peso de 100 grãos em função do nível de saturação de água e potássio. Contornos e rótulo na escala de cores são os destaques desse gráfico.

Mais uma ridícula de lattice. Fiz duas coisas: adicionei rótulo à legenda de cores (colorkey) e coloquei contornos sobre o gráfico de níveis. Assim como a maioria das dicas gráficas, essa também é baseada nas mensagens da r-help. Os respectivos links estão no CMR. Até a próxima ridícula.

#-----------------------------------------------------------------------------
# leitura dos dados

soja <- read.table("http://www.leg.ufpr.br/~walmes/cursoR/cnpaf/soja.txt",
                   header=TRUE, sep="\t", dec=",")
str(soja)

#-----------------------------------------------------------------------------
# ver o peso de 100 grãos

require(lattice)

xyplot(pesograo~potassio, groups=agua, data=soja, type=c("p","a"))
xyplot(pesograo~potassio|agua, data=soja, type=c("p","a"))

#-----------------------------------------------------------------------------
# ajuste de um modelo polinomial nos dois fatores

m0 <- lm(pesograo~bloco+poly(agua,2)*poly(potassio,2), data=soja)
par(mfrow=c(2,2)); plot(m0); layout(1)

summary(influence.measures(m0))
soja[55,] # influente segundo dffits

m0 <- lm(pesograo~bloco+poly(agua,2)*poly(potassio,2),
         data=soja[-55,])
par(mfrow=c(2,2)); plot(m0); layout(1)

anova(m0)
summary(m0)

m1 <- lm(pesograo~bloco+(agua+I(agua^2))*potassio+I(potassio^2),
         data=soja[-55,])
par(mfrow=c(2,2)); plot(m1); layout(1)

anova(m0, m1)
summary(m1)

#-----------------------------------------------------------------------------
# fazendo a predição

pred <- expand.grid(bloco="I", agua=seq(37.5,62.5,l=30),
                    potassio=seq(0,180,l=30))
pred$y <- predict(m1, newdata=pred)

#-----------------------------------------------------------------------------
# representando com wireframe()

require(RColorBrewer)

display.brewer.all()
colr <- brewer.pal(11, "RdYlGn")
colr <- colorRampPalette(colr, space="rgb")

zlab <- "Peso de 100 grãos"
xlab <- "Potássio no solo"
ylab <- "Nível de saturação de água"

wireframe(y~potassio*agua, data=pred,
          scales=list(arrows=FALSE), zlab=list(zlab, rot=90),
          xlab=list(xlab, rot=24), ylab=list(ylab, rot=-37),
          col.regions=colr(100),  drape=TRUE,
          screen=list(z=40, x=-70))

#-----------------------------------------------------------------------------
# representando em um levelplot()

# grid mais fino
pred <- expand.grid(bloco="I", agua=seq(37.5,62.5,l=100),
                    potassio=seq(0,180,l=100))
pred$y <- predict(m1, newdata=pred)

levelplot(y~potassio*agua, data=pred, col.regions=colr(100),
          xlab=xlab, ylab=ylab)

#-----------------------------------------------------------------------------
# adicionando rotulo à legenda de cores, baseado nas mensagens da r-help
# http://r.789695.n4.nabble.com/Adding-title-to-colorkey-td4633584.html

library(grid)

# modo 1
levelplot(y~potassio*agua, data=pred, col.regions=colr(100),
          xlab=xlab, ylab=ylab,
          par.settings=list(layout.widths=list(axis.key.padding=4)))
grid.text(zlab, x=unit(0.88, "npc"), y=unit(0.5, "npc"), rot=90)

# modo 2
levelplot(y~potassio*agua, data=pred, col.regions=colr(100),
          xlab=xlab, ylab=ylab,
          ylab.right=zlab,
          par.settings=list(
            layout.widths=list(axis.key.padding=0, ylab.right=2)))

require(latticeExtra)

# modo 3
p <- levelplot(y~potassio*agua, data=pred, col.regions=colr(100),
               xlab=xlab, ylab=ylab,
               par.settings=list(
                 layout.widths=list(right.padding=4)))
p$legend$right <- list(fun=mergedTrellisLegendGrob(p$legend$right,
                         list(fun=textGrob, args=list(zlab, rot=-90, x=2)),
                         vertical=FALSE))
print(p)

#-----------------------------------------------------------------------------
# adicionando contornos, baseado em
# https://stat.ethz.ch/pipermail/r-help/2006-February/088166.html

#png(file="f037.png", width=500, height=400)
p <- levelplot(y~potassio*agua, data=pred, col.regions=colr(100),
               xlab=xlab, ylab=ylab,
               panel=function(..., at, contour=FALSE, labels=NULL){
                 panel.levelplot(..., at=at, contour=contour, labels=labels)
                 panel.contourplot(..., at=at, contour=TRUE,
                                   labels=list(labels=format(at, digits=4),
                                     cex=0.9))
               },
               par.settings=list(
                 layout.widths=list(right.padding=4)))
p$legend$right <- list(fun=mergedTrellisLegendGrob(p$legend$right,
                         list(fun=textGrob, args=list(zlab, rot=-90, x=2)),
                         vertical=FALSE))
print(p)
#dev.off()

#-----------------------------------------------------------------------------
Anúncios
Categorias:gráficos Tags:,

Como adicionar legendas em gráficos da lattice

Gráfico com bandas de confiança, legenda e assinatura de autor e versão.

No post Como fazer legendas em gráficos eu mostrei procedimentos para gráficos do pacote graphics. Nesse post vou apresentar procedimento para fazer legendas em gráficos da lattice, desenvolvido por Deepayan Sarkar. Iremos empregar as opções auto.key=, key=, colorkey=, e as funções draw.key() e draw.colorkey(). O pacote grid, desenvolvido por Paul Murrell será necessário para posicionarmos as legendas na página gráfica. Nos exemplos temos legendas para pontos, linhas, pontos e linhas, barras, escala de cores para gráficos de três dimensões, gráfico com duas legendas, posicionamento da legenda com o mouse e gráfico com legenda para representar o ajuste de um modelo de regressão com valores observados, preditos e intervalo de confiança.

#-----------------------------------------------------------------------------
# pacotes

require(lattice) # para fazer os gráficos
require(grid)    # para posicionar as legendas

#-----------------------------------------------------------------------------
# dados de indice agronômico em função da cultivar de milho e dose de N

da <- read.table("http://www.leg.ufpr.br/~walmes/cursoR/anovareg.txt",
                 header=TRUE, sep="\t")
str(da)

#-----------------------------------------------------------------------------
# legenda para gráfico de dispersão

# gráfico com legenda padrão
xyplot(indice~dose, groups=cultivar, data=da, jitter.x=TRUE, auto.key=TRUE)

# gráfico com legenda em colunas e alteração dos padrões dos pontos
xyplot(indice~dose, groups=cultivar, data=da, jitter.x=TRUE,
       auto.key=list(columns=3),
       par.settings=list(superpose.symbol=list(pch=15:17, col=3:5, cex=1.2)))

# muda a posição da legenda
xyplot(indice~dose, groups=cultivar, data=da, jitter.x=TRUE,
       auto.key=list(space="right", columns=1),
       par.settings=list(superpose.symbol=list(pch=15:17, col=3:5, cex=1.2)))

# coloca a legenda dentro do gráfico
xyplot(indice~dose, groups=cultivar, data=da, jitter.x=TRUE,
       auto.key=list(corner=c(0.95,0.05), columns=1),
       par.settings=list(superpose.symbol=list(pch=15:17, col=3:5, cex=1.2)))

#-----------------------------------------------------------------------------
# legenda para gráfico de linhas

db <- with(da, aggregate(indice, list(cultivar=cultivar, dose=dose), mean))
col <- trellis.par.get("superpose.line")$col[1:nlevels(db$cultivar)]

# gráfico com legendas de linhas, nomes *antes* das linhas
xyplot(x~dose, groups=cultivar, data=db, type="l",
       key=list(corner=c(0.95,0.05), columns=1,
         text=list(levels(db$cultivar)),
         lines=list(col=col)))

# gráfico com legendas de linhas, nomes *depois* das linhas
xyplot(x~dose, groups=cultivar, data=db, type="l",
       key=list(corner=c(0.95,0.05), columns=1,
         lines=list(col=col),
         text=list(levels(db$cultivar))))

#-----------------------------------------------------------------------------
# legenda para gráfico de linhas e pontos

xyplot(x~dose, groups=cultivar, data=db, type="o", pch=19,
       key=list(corner=c(0.95,0.05), columns=1,
         type="o", divide=1,
         lines=list(col=col, pch=19),
         text=list(levels(db$cultivar))))

#-----------------------------------------------------------------------------
# legenda para pontos e reta de regressão

# ajuste de modelo e criação de objeto com valores observados e preditos
m0 <- lm(indice~cultivar*(dose+I(dose^2)), data=da)
dc <- expand.grid(cultivar=levels(da$cultivar), dose=seq(0,300,l=100))
dc$indice <- predict(m0, newdata=dc)
dc$ind <- "predito"
da$ind <- "obsevado"
dc <- rbind(da[,-3], dc)
str(dc)

# legenda fora do gráfico
xyplot(indice~dose|cultivar, groups=ind, data=dc,
       distribute.type=TRUE, type=c("p","l"), col=1, layout=c(3,1),
       key=list(space="top", columns=2, type="o", divide=1,
         lines=list(pch=c(1,NA), lty=c(0,1)),
         text=list(c("valores observados","valores preditos"))))

# legenda dentro do gráfico
xyplot(indice~dose|cultivar, groups=ind, data=dc,
       distribute.type=TRUE, type=c("p","l"), col=1, layout=c(3,1),
       key=list(corner=c(0.95,0.05), columns=1, type="o", divide=1,
         lines=list(pch=c(1,NA), lty=c(0,1)),
         text=list(c("valores observados","valores preditos"))))

#-----------------------------------------------------------------------------
# dados de mortalidade de aves em função do tipo de resfriamento do aviário

ma <- read.table("http://www.leg.ufpr.br/~walmes/cursoR/mortes.txt",
                 header=TRUE, sep="\t")
str(ma)

#-----------------------------------------------------------------------------
# legenda para gráficos de barras

mb <- with(ma, aggregate(mortes, list(galpao=galpao, sistema=asper), sum))
str(mb)

col <- c("forestgreen", "palegreen")

# legenda fora da região gráfica
barchart(x~galpao, groups=sistema, data=mb, horiz=FALSE, col=col,
         key=list(space="top", columns=2,
           rectangles=list(col=col),
           text=list(c("com aspersão","sem aspersão"))))

# legenda fora da região gráfica com título
barchart(x~galpao, groups=sistema, data=mb, horiz=FALSE, col=col,
         key=list(title="Sistema de resfriamento", cex.title=1.1,
           space="top", columns=2,
           rectangles=list(col=col),
           text=list(c("com aspersão","sem aspersão"))))

# legenda dentro da região gráfica com título
barchart(x~galpao, groups=sistema, data=mb, horiz=FALSE, col=col,
         key=list(title="Sistema de resfriamento", cex.title=1.1,
           corner=c(0.05,0.95), columns=1, padding.text=2,
           rectangles=list(col=col, size=3, height=0.8, border=TRUE),
           text=list(c("com aspersão","sem aspersão"))))

#-----------------------------------------------------------------------------
# escolhendo a posição da legenda com o mouse

barchart(x~galpao, groups=sistema, data=mb, horiz=FALSE, col=col)
trellis.focus(name="page")
loc <- grid.locator(unit="npc") # clicar no gráfico
trellis.unfocus()

barchart(x~galpao, groups=sistema, data=mb, horiz=FALSE, col=col,
         key=list(title="Sistema de\nresfriamento", cex.title=1.1,
           x=loc$x, y=loc$y, corner=c(0.5,0.5), columns=1, padding.text=2,
           rectangles=list(col=col, size=3, height=0.8, border=TRUE),
           text=list(c("com\naspersão","sem\naspersão"))))

#-----------------------------------------------------------------------------
# nota de rodapé no gráfico com assinatura, data e versão

# ajuste de modelo e criação de objeto com valores observados, preditos e IC
m0 <- lm(indice~cultivar*(dose+I(dose^2)), data=da)
dc <- expand.grid(cultivar=levels(da$cultivar), dose=seq(0,300,l=100))
indice <- predict(m0, newdata=dc, interval="confidence")
dc <- cbind(dc, stack(data.frame(indice)))
names(dc)[3] <- "indice"
dc <- rbind(da[,-3], dc)

#png("f017.png", w=500, h=350)
xyplot(indice~dose|cultivar, groups=ind, data=dc,
       distribute.type=TRUE, type=c("l","l","p","l"),
       col=1, lty=c(1,2,0,2), layout=c(3,1),
       strip=strip.custom(bg="gray90"),
       xlab="Dose de nitrogênio (kg/ha)", ylab="Índice agronômico",
       key=list(space="top", columns=3, type="o", divide=1,
         lines=list(pch=c(1,NA,NA), lty=c(0,1,2)),
         text=list(c("valores observados","valores preditos","IC 95%"))))
pushViewport(viewport())
grid.text(label=paste("Walmes Zeviani --",
            format(Sys.time(), "%d/%m/%Y %H:%M:%S --"),
            R.version.string), rot=90,
          x=unit(1, "npc")-unit(2, "mm"),
          y=unit(0, "npc")+unit(2, "mm"),
          just=c("left", "bottom"),
          gp=gpar(cex=0.8, col="gray50"))
popViewport()
#dev.off()

#-----------------------------------------------------------------------------
# legenda para gráficos de 3 dimensões

x <- seq(-10,10,l=50)
dd <- expand.grid(x=x, y=x)
dd$z <- with(dd, 500+x+2*y-0.5*x*y-x^2-y^2)

# gráfico sem cores e sem legenda
wireframe(z~x+y, data=dd)

# gráfico com cores e legenda
wireframe(z~x+y, data=dd, drape=TRUE)

# remove a legenda
wireframe(z~x+y, data=dd, drape=TRUE, colorkey=FALSE)

# coloca a legenda embaixo
wireframe(z~x+y, data=dd, drape=TRUE, colorkey=list(space="bottom"))

# redimensionando a legenda
wireframe(z~x+y, data=dd, drape=TRUE,
          colorkey=list(width=1, height=0.7))

# gráfico de níveis de cor
levelplot(z~x+y, data=dd)

# com contornos e redimensiomento da legenda
levelplot(z~x+y, data=dd, contour=TRUE,
          colorkey=list(width=1, height=0.7))

#-----------------------------------------------------------------------------
# usando a draw.key(), usar fora da função gráfica ou dentro da panel()

xyplot(indice~dose|cultivar, groups=ind, data=dc,
       distribute.type=TRUE, type=c("l","l","p","l"),
       col=1, lty=c(1,2,0,2), layout=c(2,2),
       strip=strip.custom(bg="gray90"),
       xlab="Dose de nitrogênio (kg/ha)", ylab="Índice agronômico")
draw.key(list(space="top", columns=1, type="o", divide=1,
         lines=list(pch=c(1,NA,NA), lty=c(0,1,2)),
         text=list(c("valores observados","valores preditos","IC 95%"))),
         draw=TRUE,
         vp=viewport(x=unit(0.75, "npc"), y=unit(0.65, "npc")))

#-----------------------------------------------------------------------------
# usando a draw.colorkey(), usar fora da função gráfica ou dentro da panel()

wireframe(z~x+y, data=dd, drape=TRUE, colorkey=FALSE,
          panel=function(...){
            panel.wireframe(...)
            draw.colorkey(list(space="bottom", at=seq(250,500,25),
                               height=0.8, width=1), draw=TRUE,
                          vp=viewport(x=unit(0.5,"npc"), y=unit(0.07,"npc")))
          })

#-----------------------------------------------------------------------------
# usando duas legendas

de <- expand.grid(w=gl(3,5,la="w"), z=gl(4,3,la="z"))
de$x <- with(de, rnorm(w, as.numeric(w), 0.5))
de$y <- with(de, rnorm(z, as.numeric(z), 0.5))
pch <- c(1,2,5,7); col=1:3

xy <- xyplot(y~x, data=de, groups=z:w,
             pch=rep(pch, e=3), col=rep(col, 4))

print(xy, position=c(0,0,0.8,1), more=FALSE)
draw.key(list(text=list(levels(de$z)), points=list(pch=pch, col=1),
         space="top", columns=1, title="Níveis de Z", cex.title=1.1),
         draw=TRUE, vp=viewport(x=unit(0.85, "npc"), y=unit(0.6, "npc")))
draw.key(list(text=list(levels(de$w)), points=list(pch=15, col=col),
         space="top", columns=1, title="Níveis de W", cex.title=1.1),
         draw=TRUE, vp=viewport(x=unit(0.85, "npc"), y=unit(0.4, "npc")))

#-----------------------------------------------------------------------------