[R-br] Biblioteca ExpDes.pt
Alan Rodrigo Panosso
alan.panosso em unesp.br
Seg Dez 18 06:45:45 -03 2023
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
-------------- Próxima Parte ----------
Um anexo em HTML foi limpo...
URL: <http://listas.inf.ufpr.br/pipermail/r-br/attachments/20231218/be7b3d04/attachment.htm>
Mais detalhes sobre a lista de discussão R-br