Não foi possível enviar o arquivo. Será algum problema com as permissões?
Diferenças
Aqui você vê as diferenças entre duas revisões dessa página.
Ambos lados da revisão anterior Revisão anterior Próxima revisão | Revisão anterior Próxima revisão Ambos lados da revisão seguinte | ||
pessoais:jcfaria [2007/03/02 18:35] jcfaria |
pessoais:jcfaria [2012/08/01 09:18] jcfaria |
||
---|---|---|---|
Linha 591: | Linha 591: | ||
</code> | </code> | ||
- | ==== Funções úteis ==== | + | ==== Scripts ==== |
- | === Tabelas e histogramas === | + | |
- | == Função tb.table == | + | |
- | + | ||
- | Função simples, flexível mas poderosa para descrever, via tabela de distribuição de freqüências e histogramas, vetores e data.frames. | + | |
- | + | ||
- | <code> | + | |
- | #=============================================================================== | + | |
- | # Name : tb.table | + | |
- | # Original author: José Cláudio Faria, Gabor Gothendievisk and Enio Jelihovschi | + | |
- | # Date (dd/mm/yy): 1/3/07 11:06:02 | + | |
- | # Version : v24 | + | |
- | # Aim : To make tables of frequency distribution and associated | + | |
- | # histogram | + | |
- | #=============================================================================== | + | |
- | # Arguments: | + | |
- | # breaks : Method to determine number of classes= c('Sturges', 'Scott', 'FD') | + | |
- | # by : Variable to group | + | |
- | # end : Last class (high value) | + | |
- | # h : Classes extent | + | |
- | # k : Class number | + | |
- | # right : Intervals right open (default = FALSE) | + | |
- | # start : First class (small value) | + | |
- | # x : A R object (vector or data.frame) | + | |
- | # histogram : Plot histogram (default = TRUE) | + | |
- | # title.histogram: Title of histogram c('auto', 'none') | + | |
- | #=============================================================================== | + | |
- | + | ||
- | # Common functions | + | |
- | tb.make.table.I <- function(x, | + | |
- | start, | + | |
- | end, | + | |
- | h, | + | |
- | right, | + | |
- | histogram, | + | |
- | titleH) | + | |
- | { | + | |
- | f <- table(cut(x, br=seq(start, end, h), right=right)) # Absolut freq | + | |
- | fr <- f/length(x) # Relative freq | + | |
- | frP <- 100*(f/length(x)) # Relative freq, % | + | |
- | fac <- cumsum(f) # Cumulative freq | + | |
- | facP <- 100*(cumsum(f/length(x))) # Cumulative freq, % | + | |
- | fi <- round(f, 2) | + | |
- | fr <- round(as.numeric(fr), 2) | + | |
- | frP <- round(as.numeric(frP), 2) | + | |
- | fac <- round(as.numeric(fac), 2) | + | |
- | facP <- round(as.numeric(facP),2) | + | |
- | res <- data.frame(fi, fr, frP, fac, facP) # Make final table | + | |
- | names(res) <- c('Class limits', 'fi', 'fr', 'fr(%)', 'fac', 'fac(%)') | + | |
- | + | ||
- | # Making the histogram: With Benilton suggestions | + | |
- | if (histogram) { | + | |
- | hist(x, | + | |
- | breaks = seq(start, end, h), | + | |
- | freq = T, | + | |
- | right = right, | + | |
- | xlab = 'Class limits', ylab='Frequency', | + | |
- | col = 'LightYellow', | + | |
- | main = titleH, | + | |
- | xlim = c(start, end), ylim=c(0, max(fi)), | + | |
- | las = 1, | + | |
- | xaxt = 'n') | + | |
- | axis(1, at=round(seq(start, end, h), 2)) | + | |
- | } | + | |
- | return(res) | + | |
- | } | + | |
- | + | ||
- | tb.make.table.II <- function (x, | + | |
- | k, | + | |
- | breaks=c('Sturges', 'Scott', 'FD'), | + | |
- | right=FALSE, | + | |
- | histogram, | + | |
- | titleH) | + | |
- | { | + | |
- | x <- na.omit(x) | + | |
- | + | ||
- | # User defines only x and/or 'breaks' | + | |
- | # (x, {k,}[breaks, right]) | + | |
- | if (missing(k)) { | + | |
- | brk <- match.arg(breaks) | + | |
- | switch(brk, | + | |
- | Sturges = k <- nclass.Sturges(x), | + | |
- | Scott = k <- nclass.scott(x), | + | |
- | FD = k <- nclass.FD(x)) | + | |
- | tmp <- range(x) | + | |
- | start <- tmp[1] - abs(tmp[2])/100 | + | |
- | end <- tmp[2] + abs(tmp[2])/100 | + | |
- | R <- end-start | + | |
- | h <- R/k | + | |
- | } | + | |
- | + | ||
- | # User defines 'x' and 'k' | + | |
- | # (x, k,[breaks, right]) | + | |
- | else { | + | |
- | tmp <- range(x) | + | |
- | start <- tmp[1] - abs(tmp[2])/100 | + | |
- | end <- tmp[2] + abs(tmp[2])/100 | + | |
- | R <- end-start | + | |
- | h <- R/abs(k) | + | |
- | } | + | |
- | tbl <- tb.make.table.I(x, start, end, h, right, histogram, titleH) | + | |
- | return(tbl) | + | |
- | } | + | |
- | + | ||
- | # With Gabor Grotendieck suggestions (thanks Gabor, very much!) | + | |
- | tb.table <- function(x, ...) UseMethod("tb.table") | + | |
- | + | ||
- | # Table form vectors | + | |
- | tb.table.default <- function(x, | + | |
- | k, | + | |
- | start, | + | |
- | end, | + | |
- | h, | + | |
- | breaks=c('Sturges', 'Scott', 'FD'), | + | |
- | right=FALSE, | + | |
- | histogram=TRUE, | + | |
- | title.histogram=c('auto', 'none')) | + | |
- | { | + | |
- | # User defines nothing or not 'x' isn't numeric -> stop | + | |
- | stopifnot(is.numeric(x)) | + | |
- | x <- na.omit(x) | + | |
- | + | ||
- | # User defines only 'x' | + | |
- | # (x, {k, start, end, h}, [breaks, right]) | + | |
- | if (missing(k) && missing(start) && missing(end) && missing(h) ) { | + | |
- | brk <- match.arg(breaks) | + | |
- | switch(brk, | + | |
- | Sturges = k <- nclass.Sturges(x), | + | |
- | Scott = k <- nclass.scott(x), | + | |
- | FD = k <- nclass.FD(x)) | + | |
- | tmp <- range(x) | + | |
- | start <- tmp[1] - abs(tmp[2])/100 | + | |
- | end <- tmp[2] + abs(tmp[2])/100 | + | |
- | R <- end-start | + | |
- | h <- R/k | + | |
- | } | + | |
- | + | ||
- | # User defines 'x' and 'k' | + | |
- | # (x, k, {start, end, h}, [breaks, right]) | + | |
- | else if (missing(start) && missing(end) && missing(h)) { | + | |
- | stopifnot(length(k) >= 1) | + | |
- | tmp <- range(x) | + | |
- | start <- tmp[1] - abs(tmp[2])/100 | + | |
- | end <- tmp[2] + abs(tmp[2])/100 | + | |
- | R <- end-start | + | |
- | h <- R/abs(k) | + | |
- | } | + | |
- | + | ||
- | # User defines 'x', 'start' and 'end' | + | |
- | # (x, {k,} start, end, {h,} [breaks, right]) | + | |
- | else if (missing(k) && missing(h)) { | + | |
- | stopifnot(length(start) >= 1, length(end) >=1) | + | |
- | tmp <- range(x) | + | |
- | R <- end-start | + | |
- | k <- sqrt(abs(R)) | + | |
- | if (k < 5) k <- 5 # min value of k | + | |
- | h <- R/k | + | |
- | } | + | |
- | + | ||
- | # User defines 'x', 'start', 'end' and 'h' | + | |
- | # (x, {k,} start, end, h, [breaks, right]) | + | |
- | else if (missing(k)) { | + | |
- | stopifnot(length(start) >= 1, length(end) >= 1, length(h) >= 1) | + | |
- | } | + | |
- | + | ||
- | else stop('Please, see the function sintax!') | + | |
- | + | ||
- | if (histogram) { | + | |
- | x11() | + | |
- | par(mfrow=c(1, 1)) | + | |
- | title.histogram <- match.arg(title.histogram) | + | |
- | switch(title.histogram, | + | |
- | auto = titleH <- 'x', | + | |
- | none = titleH <- '') | + | |
- | } | + | |
- | tbl <- tb.make.table.I(x, start, end, h, right, histogram, titleH) | + | |
- | return(tbl) | + | |
- | } | + | |
- | + | ||
- | # Table form data.frames | + | |
- | tb.table.data.frame <- function(df, | + | |
- | k, | + | |
- | by, | + | |
- | breaks=c('Sturges', 'Scott', 'FD'), | + | |
- | right=FALSE, | + | |
- | histogram=TRUE, | + | |
- | title.histogram=c('auto', 'none')) | + | |
- | { | + | |
- | stopifnot(is.data.frame(df)) | + | |
- | tmpList <- list() | + | |
- | nameF <- character() | + | |
- | nameY <- character() | + | |
- | + | ||
- | # User didn't defines a factor | + | |
- | if (missing(by)) { | + | |
- | logCol <- sapply(df, is.numeric) | + | |
- | nHist <- length(logCol[logCol]) | + | |
- | if (histogram) { | + | |
- | count = 0 | + | |
- | if (nHist > 1) { | + | |
- | x11() | + | |
- | par(mfrow=c(4, 1)) | + | |
- | } | + | |
- | } | + | |
- | for (i in 1:ncol(df)) { | + | |
- | if (logCol[i]) { | + | |
- | count <- (count + 1) | + | |
- | if (count == 5) { | + | |
- | x11() | + | |
- | par(mfrow=c(4, 1)) | + | |
- | count <- 1 | + | |
- | } | + | |
- | title.histogram <- match.arg(title.histogram) | + | |
- | switch(title.histogram, | + | |
- | auto = titleH <- names(logCol[i]), | + | |
- | none = titleH <- '') | + | |
- | x <- as.matrix(df[ ,i]) | + | |
- | tbl <- tb.make.table.II(x, k, breaks, right, histogram, titleH) | + | |
- | tmpList <- c(tmpList, list(tbl)) | + | |
- | } | + | |
- | } | + | |
- | valCol <- logCol[logCol] | + | |
- | names(tmpList) <- names(valCol) | + | |
- | return(tmpList) | + | |
- | } | + | |
- | + | ||
- | # User defines one factor | + | |
- | else { | + | |
- | namesdf <- names(df) | + | |
- | pos <- which(namesdf == by) | + | |
- | stopifnot(is.factor((df[[pos]]))) | + | |
- | nF <- table(df[[pos]]) | + | |
- | logCol <- sapply(df, is.numeric) | + | |
- | nHist <- length(logCol[logCol]) | + | |
- | nDisGraph <- round((length(nF) * nHist) / 12) # 12 is the maximum easily visible | + | |
- | if (histogram) { | + | |
- | count <- 0 | + | |
- | x11() | + | |
- | par(mfrow=c(4, 3)) | + | |
- | } | + | |
- | for(i in 1:length(nF)) { | + | |
- | tmpdf <- subset(df, df[[pos]] == names(nF[i])) | + | |
- | logCol <- sapply(tmpdf, is.numeric) | + | |
- | for (j in 1:ncol(tmpdf)) { | + | |
- | if (logCol[j]) { | + | |
- | count <- (count + 1) | + | |
- | if (count == 13) { | + | |
- | x11() | + | |
- | par(mfrow=c(4, 3)) | + | |
- | count <- 1 | + | |
- | } | + | |
- | nameF <- names(nF[i]) | + | |
- | nameY <- names(logCol[j]) | + | |
- | nameFY <- paste(nameF,'.', nameY, sep="") | + | |
- | title.histogram <- match.arg(title.histogram) | + | |
- | switch(title.histogram, | + | |
- | auto = titleH <- nameFY, | + | |
- | none = titleH <- '') | + | |
- | x <- as.matrix(tmpdf[ ,j]) | + | |
- | tbl <- tb.make.table.II(x, k, breaks, right, histogram, titleH) | + | |
- | newFY <- list(tbl) | + | |
- | names(newFY) <- sub(' +$', '', nameFY) | + | |
- | tmpList <- c(tmpList, newFY) | + | |
- | } | + | |
- | } | + | |
- | } | + | |
- | } | + | |
- | return(tmpList) | + | |
- | } | + | |
- | </code> | + | |
- | + | ||
- | == Testar função tb.table == | + | |
- | O script abaixo possibilita testar e aprender a usar a função tb.table. | + | |
- | + | ||
- | <code> | + | |
- | #=============================================================================== | + | |
- | # Name : tb.table_test | + | |
- | # Original author: Jose Cláudio Faria | + | |
- | # Date (dd/mm/yy): 1/3/07 11:06:02 | + | |
- | # Version : v24 | + | |
- | # Aim : To learn how to use the function tb.table | + | |
- | #=============================================================================== | + | |
- | # Observation : Test it line by line | + | |
- | #=============================================================================== | + | |
- | # 1.Tables | + | |
- | # 1.1. Tables from vectors | + | |
- | #=============================================================================== | + | |
- | + | ||
- | ## To debug | + | |
- | # mtrace.off() | + | |
- | # mtrace(tb.make.table.I) | + | |
- | # mtrace(tb.make.table.II) | + | |
- | # mtrace(tb.table.default) | + | |
- | # mtrace(tb.table.data.frame) | + | |
- | + | ||
- | # Make a vector | + | |
- | set.seed(1) | + | |
- | x=rnorm(150, 5, 1) | + | |
- | + | ||
- | tb.table(x, his=F) | + | |
- | tb.table(x) | + | |
- | tb.table(x, title.his='none') | + | |
- | tb.table(x, k=10, his=T) | + | |
- | + | ||
- | #Title | + | |
- | tb.table(x, title.his='teste') #error! | + | |
- | tb.table(x, title.his='none') | + | |
- | tb.table(x, title.his='auto') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(x, breaks='Sturges') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(x, breaks='St') | + | |
- | + | ||
- | tb.table(x, breaks='Scott') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(x, b='Sc') | + | |
- | + | ||
- | tb.table(x, breaks='FD') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(x, breaks='F') | + | |
- | + | ||
- | tb.table(x, breaks='F', right=T) | + | |
- | + | ||
- | # Will make a error! | + | |
- | tb.table(x, breaks='S') #('S'turges) and ('S'cott) | + | |
- | + | ||
- | tb.table(x, k=4) | + | |
- | + | ||
- | tb.table(x, k=20) | + | |
- | + | ||
- | # Partial | + | |
- | tb.table(x, start=4, end=6) # Will make error! | + | |
- | tb.table(x, start=4, end=6, his=F) | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(x, s=4, e=6, his=F) | + | |
- | + | ||
- | # Partial | + | |
- | tb.table(x, start=4.5, end=5.5, his=F) | + | |
- | + | ||
- | # Partial | + | |
- | tb.table(x, start=5, end=6, h=.5, his=F) | + | |
- | + | ||
- | # Nonsense | + | |
- | tb.table(x, start=0, end=10, h=.5) | + | |
- | + | ||
- | # First and last class forced (fi=0) | + | |
- | tb.table(x, start=1, end=9, h=1) | + | |
- | + | ||
- | tb.table(x, start=1, end=10, h=2) | + | |
- | + | ||
- | + | ||
- | #=============================================================================== | + | |
- | # 1.2. Tables from data.frames | + | |
- | #=============================================================================== | + | |
- | # Make a data.frame | + | |
- | mdf=data.frame(X1 =rep(LETTERS[1:4], 25), | + | |
- | X2 =as.factor(rep(1:10, 10)), | + | |
- | Y1 =c(NA, NA, rnorm(96, 10, 1), NA, NA), | + | |
- | Y2 =rnorm(100, 60, 4), | + | |
- | Y3 =rnorm(100, 50, 4), | + | |
- | Y4 =rnorm(100, 40, 4)) | + | |
- | + | ||
- | tb.table(mdf) | + | |
- | + | ||
- | tb.table(mdf, title.his='none') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(mdf, breaks='Sturges') | + | |
- | + | ||
- | # Equal to above | + | |
- | tb.table(mdf, breaks='St') | + | |
- | + | ||
- | tb.table(mdf, breaks='Scott') | + | |
- | + | ||
- | tb.table(mdf, breaks='FD') | + | |
- | + | ||
- | tb.table(mdf, k=4) | + | |
- | + | ||
- | tb.table(mdf, k=10) | + | |
- | + | ||
- | levels(mdf$X1) | + | |
- | tbl = tb.table(mdf, k=5, by='X1') | + | |
- | length(tbl) | + | |
- | names(tbl) | + | |
- | tbl | + | |
- | + | ||
- | tb.table(mdf, breaks='FD', by='X1') | + | |
- | + | ||
- | # A 'big' result: X2 is a factor with 10 levels! | + | |
- | tb.table(mdf, breaks='FD', by='X2') | + | |
- | + | ||
- | tb.table(mdf, breaks='FD', k=5, by='X2') | + | |
- | + | ||
- | tb.table(iris, k=5) | + | |
- | + | ||
- | tb.table(iris, k=10) | + | |
- | + | ||
- | levels(iris$Species) | + | |
- | tbl=tb.table(iris, k=5, by='Species') | + | |
- | length(tbl) | + | |
- | names(tbl) | + | |
- | tbl | + | |
- | + | ||
- | tb.table(iris, k=5, by='Species', right=T) | + | |
- | + | ||
- | tb.table(iris, breaks='FD', by='Species') | + | |
- | + | ||
- | library(MASS) | + | |
- | levels(Cars93$Origin) | + | |
- | tbl=tb.table(Cars93, k=5, by='Origin') | + | |
- | names(tbl) | + | |
- | tbl | + | |
- | + | ||
- | tb.table(Cars93, breaks='FD', by='Origin') | + | |
- | </code> | + | |
=== Superfície de resposta === | === Superfície de resposta === | ||
== Função plotlm3d == | == Função plotlm3d == | ||
Linha 1209: | Linha 789: | ||
</code> | </code> | ||
- | == Testar função tb.table == | + | == Testar função plotlm3d == |
<code> | <code> | ||
#=============================================================================== | #=============================================================================== |