[R-br] Biblioteca ExpDes.pt
Cesar Rabak
cesar.rabak em gmail.com
Seg Dez 18 18:45:38 -03 2023
Eu ainda acho que falta mais uma correção: se na chamada:
fat2.dic(revol, esterco, zn, quali=c(FALSE,TRUE),
mcomp="tukey",
fac.names=c("Revolvimento","Esterco"),
sigT = 0.05, sigF = 0.05, unfold=NULL)
o primeiro fator NÃO é qualitativo, o número de graus de liberdade deveria
ser um e não três. . . posto que revolvimento está sendo oferecido como
dado numérico. . .
Não entendo porque nossos colegas brasileiros insistem em colocar uma linha
adicional da tabela ANOVA para o total das somas quadráticas, posto que
essa informação não tem uso algum.
On Mon, Dec 18, 2023 at 6:46 AM Alan Rodrigo Panosso por (R-br) <
r-br em listas.c3sl.ufpr.br> wrote:
> Prezado André, veja se corrigiu.
>
> require(ExpDes.pt)
>
> data(ex4)
> attach(ex4)
> fat2.dic(revol, esterco, zn, quali=c(FALSE,TRUE),
> mcomp="tukey",
> fac.names=c("Revolvimento","Esterco"),
> sigT = 0.05, sigF = 0.05, unfold=NULL)
>
>
> fat2.dic <- function (fator1, fator2, resp, quali = c(TRUE, TRUE), mcomp =
> "tukey",
> fac.names = c("F1", "F2"), sigT = 0.05, sigF = 0.05, unfold =
> NULL)
> {
>
> cat("------------------------------------------------------------------------\nLegenda:\n")
> cat("FATOR 1: ", fac.names[1], "\n")
> cat("FATOR 2: ", fac.names[2],
> "\n------------------------------------------------------------------------\n\n")
> fatores <- cbind(fator1, fator2)
> Fator1 <- factor(fator1)
> Fator2 <- factor(fator2)
> nv1 <- length(summary(Fator1))
> nv2 <- length(summary(Fator2))
> lf1 <- levels(Fator1)
> lf2 <- levels(Fator2)
> anava <- aov(resp ~ Fator1 * Fator2)
> tab <- summary(anava)
> colnames(tab[[1]]) <- c("GL", "SQ", "QM", "Fc", "Pr>Fc")
> tab[[1]] <- rbind(tab[[1]], c(apply(tab[[1]], 2, sum)))
> rownames(tab[[1]]) <- c(fac.names[1], fac.names[2], paste(fac.names[1],
> "*",
> fac.names[2], sep = ""), "Residuo", "Total")
> cv <- round(sqrt(tab[[1]][4, 3])/mean(resp) * 100, 2)
> tab[[1]][5, 3] = NA
> cat("\nQuadro da analise de
> variancia\n------------------------------------------------------------------------\n")
> print(tab[[1]])
>
> cat("------------------------------------------------------------------------\nCV
> =",
> cv, "%\n")
> pvalor.shapiro <- shapiro.test(anava$residuals)$p.value
>
> cat("\n------------------------------------------------------------------------\nTeste
> de normalidade dos residuos (Shapiro-Wilk)\n")
> cat("valor-p: ", pvalor.shapiro, "\n")
> if (pvalor.shapiro < 0.05) {
> cat("ATENCAO: a 5% de significancia, os residuos nao podem ser
> considerados
> normais!\n------------------------------------------------------------------------\n")
> }
> else {
> cat("De acordo com o teste de Shapiro-Wilk a 5% de significancia, os
> residuos podem ser considerados
> normais.\n------------------------------------------------------------------------\n")
> }
> if (is.null(unfold)) {
> if (tab[[1]][3, 5] > sigF) {
> unfold <- c(unfold, 1)
> }
> if (tab[[1]][3, 5] <= sigF) {
> unfold <- c(unfold, 2)
> }
> }
> if (any(unfold == 1)) {
> cat("\nInteracao nao significativa: analisando os efeitos
> simples\n------------------------------------------------------------------------\n")
> fatores <- data.frame(`fator 1` = fator1, `fator 2` = fator2)
> for (i in 1:2) {
> if (quali[i] == TRUE && tab[[1]][i, 5] <= sigF) {
> cat(fac.names[i])
> if (mcomp == "tukey") {
> tukey(resp, fatores[, i], tab[[1]][4, 1], tab[[1]][4,
> 2], sigT)
> }
> if (mcomp == "duncan") {
> duncan(resp, fatores[, i], tab[[1]][4, 1],
> tab[[1]][4, 2], sigT)
> }
> if (mcomp == "lsd") {
> lsd(resp, fatores[, i], tab[[1]][4, 1], tab[[1]][4,
> 2], sigT)
> }
> if (mcomp == "lsdb") {
> lsdb(resp, fatores[, i], tab[[1]][4, 1], tab[[1]][4,
> 2], sigT)
> }
> if (mcomp == "sk") {
> scottknott(resp, fatores[, i], tab[[1]][4,
> 1], tab[[1]][4, 2], sigT)
> }
> if (mcomp == "snk") {
> snk(resp, fatores[, i], tab[[1]][4, 1], tab[[1]][4,
> 2], sigT)
> }
> if (mcomp == "ccboot") {
> ccboot(resp, fatores[, i], tab[[1]][4, 1],
> tab[[1]][4, 2], sigT)
> }
> if (mcomp == "ccF") {
> ccF(resp, fatores[, i], tab[[1]][4, 1], tab[[1]][4,
> 2], sigT)
> }
> }
> if (quali[i] == TRUE && tab[[1]][i, 5] > sigF) {
> cat(fac.names[i])
> cat("\nDe acordo com o teste F, as medias desse fator sao
> estatisticamente iguais.\n")
>
> cat("------------------------------------------------------------------------\n")
> mean.table <- tapply.stat(resp, fatores[, i],
> mean)
> colnames(mean.table) <- c("Niveis", "Medias")
> print(mean.table)
>
> cat("------------------------------------------------------------------------")
> }
> if (quali[i] == FALSE && tab[[1]][i, 5] <= sigF) {
> cat(fac.names[i])
> reg.poly(resp, fatores[, i], tab[[1]][4, 1],
> tab[[1]][4, 2], tab[[1]][i, 1], tab[[1]][i,
> 2])
> }
> if (quali[i] == FALSE && tab[[1]][i, 5] > sigF) {
> cat(fac.names[i])
> cat("\nDe acordo com o teste F, as medias desse fator sao
> estatisticamente iguais.\n\n")
>
> cat("------------------------------------------------------------------------\n")
> mean.table <- tapply.stat(resp, fatores[, i],
> mean)
> colnames(mean.table) <- c("Niveis", "Medias")
> print(mean.table)
>
> cat("------------------------------------------------------------------------")
> }
> cat("\n")
> }
> }
> if (any(unfold == 2)) {
> cat("\n\n\nInteracao significativa: desdobrando a
> interacao\n------------------------------------------------------------------------\n")
> cat("\nDesdobrando ", fac.names[1], " dentro de cada nivel de ",
> fac.names[2],
> "\n------------------------------------------------------------------------\n")
> des1 <- aov(resp ~ Fator2/Fator1)
> l1 <- vector("list", nv2)
> names(l1) <- names(summary(Fator2))
> v <- numeric(0)
> for (j in 1:nv2) {
> for (i in 0:(nv1 - 2)) v <- cbind(v, i * nv2 + j)
> l1[[j]] <- v
> v <- numeric(0)
> }
> des1.tab <- summary(des1, split = list(`Fator2:Fator1` = l1))[[1]]
> glb = nv2 - 1
> glf1 = c(as.numeric(des1.tab[3:(nv2 + 2), 1]))
> glE = tab[[1]][4, 1]
> glT = tab[[1]][5, 1]
> SQb = tab[[1]][2, 2]
> SQf1 = c(as.numeric(des1.tab[3:(nv2 + 2), 2]))
> SQE = tab[[1]][4, 2]
> SQT = tab[[1]][5, 2]
> QMb = SQb/glb
> QMf1 = SQf1/glf1
> QME = SQE/glE
> QMT = SQT/glT
> Fcb = QMb/QME
> Fcf1 = QMf1/QME
> rn <- numeric(0)
> for (j in 1:nv2) {
> rn <- c(rn, paste(paste(fac.names[1], ":", fac.names[2],
> sep = ""), lf2[j]))
> }
> anavad1 <- data.frame(GL = c(round(c(glb, glf1, glE,
> glT))), SQ = c(round(c(SQb, SQf1,
> SQE, SQT), 5)),
> QM = c(round(c(QMb, QMf1, QME, QMT), 5)), Fc =
> c(round(c(Fcb,
>
> Fcf1), 4), " ", " "), `Pr>Fc` = c(round(c(1 -
>
> pf(Fcb, glb, glE), 1 -
> pf(Fcf1, glf1, glE)),
>
> 4), "", ""))
> rownames(anavad1) = c(fac.names[2], rn, "Residuo", "Total")
>
> cat("------------------------------------------------------------------------\nQuadro
> da analise de
> variancia\n------------------------------------------------------------------------\n")
> print(anavad1)
>
> cat("------------------------------------------------------------------------\n\n")
> for (i in 1:nv2) {
> if (des1.tab[(i + 2), 5] <= sigF) {
> if (quali[1] == TRUE) {
> cat("\n\n", fac.names[1], " dentro do nivel ",
> lf2[i], " de ", fac.names[2],
> "\n------------------------------------------------------------------------")
> if (mcomp == "tukey") {
> tukey(resp[Fator2 == lf2[i]], fatores[, 1][Fator2 ==
> lf2[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "duncan") {
> duncan(resp[Fator2 == lf2[i]], fatores[,
> 1][Fator2 == lf2[i]],
> tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "lsd") {
> lsd(resp[Fator2 == lf2[i]], fatores[, 1][Fator2 ==
> lf2[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "lsdb") {
> lsdb(resp[Fator2 == lf2[i]], fatores[, 1][Fator2 ==
> lf2[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "sk") {
> scottknott(resp[Fator2 == lf2[i]], fatores[,
> 1][Fator2 ==
> lf2[i]], tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "snk") {
> snk(resp[Fator2 == lf2[i]], fatores[, 1][Fator2 ==
> lf2[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "ccboot") {
> ccboot(resp[Fator2 == lf2[i]], fatores[,
> 1][Fator2 == lf2[i]],
> tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "ccF") {
> ccF(resp[Fator2 == lf2[i]], fatores[, 1][Fator2 ==
> lf2[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> }
> else {
> cat("\n\n", fac.names[1], " dentro do nivel ",
> lf2[i], " de ", fac.names[2],
> "\n------------------------------------------------------------------------")
> reg.poly(resp[Fator2 == lf2[i]], fator1[Fator2 ==
> lf2[i]], tab[[1]][4,
> 1], tab[[1]][4, 2],
> des1.tab[i + 2, 1], des1.tab[i + 2, 2])
> }
> }
> else {
> cat("\n\n", fac.names[1], " dentro do nivel ",
> lf2[i], " de ", fac.names[2], "\n")
> cat("\nDe acordo com o teste F, as medias desse fator sao
> estatisticamente iguais.\n")
>
> cat("------------------------------------------------------------------------\n")
> mean.table <- tapply.stat(resp[Fator2 == lf2[i]],
> fatores[, 1][Fator2 == lf2[i]], mean)
> colnames(mean.table) <- c("Niveis", "Medias")
> print(mean.table)
>
> cat("------------------------------------------------------------------------\n")
> }
> }
> cat("\n\n")
> cat("\nDesdobrando ", fac.names[2], " dentro de cada nivel de ",
> fac.names[1],
> "\n------------------------------------------------------------------------\n")
> des2 <- aov(resp ~ Fator1/Fator2)
> l2 <- vector("list", nv1)
> names(l2) <- names(summary(Fator1))
> v <- numeric(0)
> for (j in 1:nv1) {
> for (i in 0:(nv2 - 2)) v <- cbind(v, i * nv1 + j)
> l2[[j]] <- v
> v <- numeric(0)
> }
> des2.tab <- summary(des2, split = list(`Fator1:Fator2` = l2))[[1]]
> gla = nv1 - 1
> glf2 = c(as.numeric(des2.tab[3:(nv1 + 2), 1]))
> SQa = tab[[1]][1, 2]
> SQf2 = c(as.numeric(des2.tab[3:(nv1 + 2), 2]))
> QMa = SQa/gla
> QMf2 = SQf2/glf2
> Fca = QMa/QME
> Fcf2 = QMf2/QME
> rn <- numeric(0)
> for (i in 1:nv1) {
> rn <- c(rn, paste(paste(fac.names[2], ":", fac.names[1],
> sep = ""), lf1[i]))
> }
> anavad2 <- data.frame(GL = c(round(c(gla, glf2, glE,
> glT))), SQ = c(round(c(SQa, SQf2,
> SQE, SQT), 5)),
> QM = c(round(c(QMa, QMf2, QME, QMT), 5)), Fc =
> c(round(c(Fca,
>
> Fcf2), 4), " ", " "), `Pr>Fc` = c(round(c(1 -
>
> pf(Fca, gla, glE), 1 -
> pf(Fcf2, glf2, glE)),
>
> 4), "", ""))
> rownames(anavad2) = c(fac.names[1], rn, "Residuo", "Total")
>
> cat("------------------------------------------------------------------------\nQuadro
> da analise de
> variancia\n------------------------------------------------------------------------\n")
> print(anavad2)
>
> cat("------------------------------------------------------------------------\n\n")
> for (i in 1:nv1) {
> if (des2.tab[(i + 2), 5] <= sigF) {
> if (quali[2] == TRUE) {
> cat("\n\n", fac.names[2], " dentro do nivel ",
> lf1[i], " de ", fac.names[1],
> "\n------------------------------------------------------------------------")
> if (mcomp == "tukey") {
> tukey(resp[Fator1 == lf1[i]], fatores[, 2][Fator1 ==
> lf1[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "duncan") {
> duncan(resp[Fator1 == lf1[i]], fatores[,
> 2][Fator1 == lf1[i]],
> tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "lsd") {
> lsd(resp[Fator1 == lf1[i]], fatores[, 2][Fator1 ==
> lf1[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "lsdb") {
> lsdb(resp[Fator1 == lf1[i]], fatores[, 2][Fator1 ==
> lf1[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "sk") {
> scottknott(resp[Fator1 == lf1[i]], fatores[,
> 2][Fator1 ==
> lf1[i]], tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "snk") {
> snk(resp[Fator1 == lf1[i]], fatores[, 2][Fator1 ==
> lf1[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> if (mcomp == "ccboot") {
> ccboot(resp[Fator1 == lf1[i]], fatores[,
> 2][Fator1 == lf1[i]],
> tab[[1]][4, 1], tab[[1]][4,
>
> 2], sigT)
> }
> if (mcomp == "ccF") {
> ccF(resp[Fator1 == lf1[i]], fatores[, 2][Fator1 ==
> lf1[i]],
> tab[[1]][4, 1], tab[[1]][4, 2],
> sigT)
> }
> }
> else {
> cat("\n\n", fac.names[2], " dentro do nivel ",
> lf1[i], " de ", fac.names[1],
> "\n------------------------------------------------------------------------")
> reg.poly(resp[Fator1 == lf1[i]], fator2[Fator1 ==
> lf1[i]], tab[[1]][4,
> 1], tab[[1]][4, 2],
> des2.tab[i + 2, 1], des2.tab[i + 2, 2])
> }
> }
> else {
> cat("\n\n", fac.names[2], " dentro do nivel ",
> lf1[i], " de ", fac.names[1], "\n")
> cat("\nDe acordo com o teste F, as medias desse fator sao
> estatisticamente iguais.\n")
>
> cat("------------------------------------------------------------------------\n")
> mean.table <- tapply.stat(resp[Fator1 == lf1[i]],
> fatores[, 2][Fator1 == lf1[i]], mean)
> colnames(mean.table) <- c("Niveis", "Medias")
> print(mean.table)
>
> cat("------------------------------------------------------------------------\n")
> }
> }
> }
> out <- list()
> out$residuos <- anava$residuals
> out$gl.residual <- anava$df.residual
> out$coeficientes <- anava$coefficients
> out$efeitos <- anava$effects
> out$valores.ajustados <- anava$fitted.values
> out$medias.fator1 <- tapply.stat(resp, fatores[, 1], mean)
> out$medias.fator2 <- tapply.stat(resp, fatores[, 2], mean)
> tabmedia <- model.tables(anava, "means")
> out$medias.dentro12 <- tabmedia$tables$`Fator1:Fator2`
> invisible(out)
> }
>
> fat2.dic(revol, esterco, zn, quali=c(FALSE,TRUE),
> mcomp="tukey",
> fac.names=c("Revolvimento","Esterco"),
> sigT = 0.05, sigF = 0.05, unfold=NULL)
>
>
>
> Em seg., 18 de dez. de 2023 às 05:34, Andre Oliveira por (R-br) <
> r-br em listas.c3sl.ufpr.br> escreveu:
>
>> bom dia, *QM errado.*
>>
>> att,.
>> André
>>
>>
>> Em domingo, 17 de dezembro de 2023 às 14:30:57 BRT, Cesar Rabak por
>> (R-br) <r-br em listas.c3sl.ufpr.br> escreveu:
>>
>>
>> OK e qual era a expectativa que foi frustrada em relação ao resultado
>> obtido?
>>
>>
>> On Sun, Dec 17, 2023 at 8:06 AM Andre Oliveira por (R-br) <
>> r-br em listas.c3sl.ufpr.br> wrote:
>>
>> bom dia, segue!
>>
>> *require(ExpDes.pt)*
>>
>> *data(ex4)*
>> *attach(ex4)*
>> *fat2.dic(revol,esterco,zn,quali=c(FALSE,TRUE),mcomp="tukey", **fac.names=c("Revolvimento","Esterco"),sigT
>> = 0.05, **sigF = 0.05, unfold=NULL)*
>>
>> att,.
>> André
>>
>>
>> Em domingo, 17 de dezembro de 2023 às 08:04:57 BRT, Andre Oliveira <
>> andreolsouza em yahoo.com.br> escreveu:
>>
>>
>> bo dia dia! segue!
>>
>> att,.
>> André
>>
>>
>> Em sábado, 16 de dezembro de 2023 às 21:11:21 BRT, Cesar Rabak por (R-br)
>> <r-br em listas.c3sl.ufpr.br> escreveu:
>>
>>
>> CMR ?
>>
>>
>> On Sat, Dec 16, 2023 at 4:20 PM Andre Oliveira por (R-br) <
>> r-br em listas.c3sl.ufpr.br> wrote:
>>
>> *boa tarde,*
>> *alguém com problemas com a biblioteca ExpDes.pt? Função fatorial duplo
>> retornando o QM errado.*
>>
>> *att,.*
>> *André *
>> _______________________________________________
>> R-br mailing list
>> R-br em listas.c3sl.ufpr.br
>> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
>> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
>> código mínimo reproduzível.
>>
>> _______________________________________________
>> R-br mailing list
>> R-br em listas.c3sl.ufpr.br
>> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
>> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
>> código mínimo reproduzível.
>> _______________________________________________
>> R-br mailing list
>> R-br em listas.c3sl.ufpr.br
>> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
>> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
>> código mínimo reproduzível.
>>
>> _______________________________________________
>> R-br mailing list
>> R-br em listas.c3sl.ufpr.br
>> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
>> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
>> código mínimo reproduzível.
>> _______________________________________________
>> R-br mailing list
>> R-br em listas.c3sl.ufpr.br
>> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
>> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
>> código mínimo reproduzível.
>>
>
>
> --
>
> Alan Rodrigo Panosso
>
>
> ----------------------------------------------------------------------------
>
> Professor Assistente Doutor - Departamento de Engenharia e Ciências Exatas
> Faculdade de Ciências Agrárias e Veterinárias - FCAV - UNESP/Jaboticabal
>
> Via de Acesso Prof.Paulo Donato Castellane s/n
>
> 14884-900 - Jaboticabal, SP
>
> E_mail: alan.panosso em u <alanrp em mat.feis.unesp.br>nesp.br
> Tel.: (16) 3209-7210
> _______________________________________________
> R-br mailing list
> R-br em listas.c3sl.ufpr.br
> https://listas.inf.ufpr.br/cgi-bin/mailman/listinfo/r-br
> Leia o guia de postagem (http://www.leg.ufpr.br/r-br-guia) e forneça
> código mínimo reproduzível.
>
-------------- Próxima Parte ----------
Um anexo em HTML foi limpo...
URL: <http://listas.inf.ufpr.br/pipermail/r-br/attachments/20231218/9a677d9d/attachment.htm>
Mais detalhes sobre a lista de discussão R-br