Proyecto Final DOE 2024-03
library(ggplot2)
library(dplyr)
Adjuntando el paquete: 'dplyr'The following objects are masked from 'package:stats':
filter, lagThe following objects are masked from 'package:base':
intersect, setdiff, setequal, unionlibrary(gridExtra)
Adjuntando el paquete: 'gridExtra'The following object is masked from 'package:dplyr':
combinelibrary(lme4)Cargando paquete requerido: Matrix# Lectura de los datos
datos1<-read.table('C:/Users/FBA/OneDrive - Acesco/0. Personales/2. Profesional/20240416 - Maestria en Analítica de Datos/20240726 Diseño de Experimentos/Proyecto Final/Datos_TWSimpson.txt', header = TRUE)
datos1$Run<-as.character(datos1$Run)
datos1$A<-as.factor(datos1$A)
datos1$B<-as.factor(datos1$B)
datos1$C<-as.factor(datos1$C)
datos1$D<-as.factor(datos1$D)
datos1$E<-as.factor(datos1$E)
datos1$F<-as.factor(datos1$F)
datos1$G<-as.factor(datos1$G)
datos1 Run A B C D E F G Y
1 1 1 1 1 1 1 1 1 15.60
2 2 1 2 2 2 1 1 1 15.00
3 3 1 3 3 3 1 1 1 16.30
4 4 2 1 2 3 1 1 1 18.30
5 5 2 2 3 1 1 1 1 19.70
6 6 2 3 1 2 1 1 1 16.20
7 7 3 1 3 2 1 1 1 16.40
8 8 3 2 1 3 1 1 1 14.20
9 9 3 3 2 1 1 1 1 16.10
10 10 1 1 1 1 1 1 2 9.50
11 11 1 2 2 2 1 1 2 16.20
12 12 1 3 3 3 1 1 2 16.70
13 13 2 1 2 3 1 1 2 17.40
14 14 2 2 3 1 1 1 2 18.60
15 15 2 3 1 2 1 1 2 16.30
16 16 3 1 3 2 1 1 2 19.10
17 17 3 2 1 3 1 1 2 15.60
18 18 3 3 2 1 1 1 2 19.90
19 19 1 1 1 1 1 2 1 16.90
20 20 1 2 2 2 1 2 1 19.40
21 21 1 3 3 3 1 2 1 19.10
22 22 2 1 2 3 1 2 1 18.90
23 23 2 2 3 1 1 2 1 19.40
24 24 2 3 1 2 1 2 1 20.00
25 25 3 1 3 2 1 2 1 18.40
26 26 3 2 1 3 1 2 1 15.10
27 27 3 3 2 1 1 2 1 19.30
28 28 1 1 1 1 1 2 2 19.90
29 29 1 2 2 2 1 2 2 19.20
30 30 1 3 3 3 1 2 2 15.60
31 31 2 1 2 3 1 2 2 18.60
32 32 2 2 3 1 1 2 2 25.10
33 33 2 3 1 2 1 2 2 19.80
34 34 3 1 3 2 1 2 2 23.60
35 35 3 2 1 3 1 2 2 16.80
36 36 3 3 2 1 1 2 2 17.32
37 37 1 1 1 1 2 1 1 19.60
38 38 1 2 2 2 2 1 1 19.70
39 39 1 3 3 3 2 1 1 22.60
40 40 2 1 2 3 2 1 1 21.00
41 41 2 2 3 1 2 1 1 25.60
42 42 2 3 1 2 2 1 1 14.70
43 43 3 1 3 2 2 1 1 16.80
44 44 3 2 1 3 2 1 1 17.80
45 45 3 3 2 1 2 1 1 23.10
46 46 1 1 1 1 2 1 2 19.60
47 47 1 2 2 2 2 1 2 19.80
48 48 1 3 3 3 2 1 2 18.20
49 49 2 1 2 3 2 1 2 18.90
50 50 2 2 3 1 2 1 2 21.40
51 51 2 3 1 2 2 1 2 19.60
52 52 3 1 3 2 2 1 2 18.60
53 53 3 2 1 3 2 1 2 19.60
54 54 3 3 2 1 2 1 2 22.70
55 55 1 1 1 1 2 2 1 20.00
56 56 1 2 2 2 2 2 1 24.20
57 57 1 3 3 3 2 2 1 23.30
58 58 2 1 2 3 2 2 1 23.20
59 59 2 2 3 1 2 2 1 27.50
60 60 2 3 1 2 2 2 1 22.50
61 61 3 1 3 2 2 2 1 24.30
62 62 3 2 1 3 2 2 1 23.20
63 63 3 3 2 1 2 2 1 22.60
64 64 1 1 1 1 2 2 2 19.10
65 65 1 2 2 2 2 2 2 21.90
66 66 1 3 3 3 2 2 2 20.40
67 67 2 1 2 3 2 2 2 24.70
68 68 2 2 3 1 2 2 2 25.30
69 69 2 3 1 2 2 2 2 24.70
70 70 3 1 3 2 2 2 2 21.60
71 71 3 2 1 3 2 2 2 24.20
72 72 3 3 2 1 2 2 2 28.60fitTw<-aov(Y~A+B+C+D+E+F+G, data=datos1)
summary(fitTw) Df Sum Sq Mean Sq F value Pr(>F)
A 2 51.40 25.70 6.181 0.003624 **
B 2 12.82 6.41 1.542 0.222380
C 2 68.74 34.37 8.266 0.000675 ***
D 2 24.11 12.05 2.899 0.062826 .
E 1 276.44 276.44 66.483 2.68e-11 ***
F 1 159.97 159.97 38.472 5.62e-08 ***
G 1 0.92 0.92 0.220 0.640560
Residuals 60 249.48 4.16
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1## Calcular media y desviación en función de A,B,C y D.
datosT<-datos1 %>% group_by(A, B, C, D) %>% summarise(media = mean(Y), desviacion = sd(Y))`summarise()` has grouped output by 'A', 'B', 'C'. You can override using the
`.groups` argument.ff<- function(Y){-10*log10(1/(aggregate(Y~A+B+C+D,datos1,FUN = length)[[5]][1])*sum(1/(Y)**2))}
datosT2<-datos1 %>% group_by(A, B, C, D) %>% summarise(metrica=ff(Y))`summarise()` has grouped output by 'A', 'B', 'C'. You can override using the
`.groups` argument.datosT$SNL<-datosT2[[5]]
datosT# A tibble: 9 × 7
# Groups: A, B, C [9]
A B C D media desviacion SNL
<fct> <fct> <fct> <fct> <dbl> <dbl> <dbl>
1 1 1 1 1 17.5 3.61 24.0
2 1 2 2 2 19.4 2.91 25.5
3 1 3 3 3 19.0 2.88 25.3
4 2 1 2 3 20.1 2.60 25.9
5 2 2 3 1 22.8 3.43 26.9
6 2 3 1 2 19.2 3.38 25.3
7 3 1 3 2 19.8 2.98 25.7
8 3 2 1 3 18.3 3.73 24.8
9 3 3 2 1 21.2 3.95 26.2#Calculamos SN_N por factor por nivel
AvgSN_A<-aggregate(SNL~A,data=datosT,mean)
AvgSN_B<-aggregate(SNL~B,data=datosT,mean)
AvgSN_C<-aggregate(SNL~C,data=datosT,mean)
AvgSN_D<-aggregate(SNL~D,data=datosT,mean)
AvgSN_A A SNL
1 1 24.95353
2 2 26.04584
3 3 25.56407AvgSN_B B SNL
1 1 25.21347
2 2 25.74524
3 3 25.60474AvgSN_C C SNL
1 1 24.72627
2 2 25.85281
3 3 25.98437AvgSN_D D SNL
1 1 25.69553
2 2 25.51234
3 3 25.35557#Calculamos Promedio de media por factor por nivel
media_A<-aggregate(media~A,data=datosT,mean)
media_B<-aggregate(media~B,data=datosT,mean)
media_C<-aggregate(media~C,data=datosT,mean)
media_D<-aggregate(media~D,data=datosT,mean)
media_A A media
1 1 18.65833
2 2 20.72500
3 3 19.78833media_B B media
1 1 19.16667
2 2 20.18750
3 3 19.81750media_C C media
1 1 18.35417
2 2 20.25083
3 3 20.56667media_D D media
1 1 20.51750
2 2 19.50000
3 3 19.15417#Graficamos SNL ~ Factores
gg1<-ggplot(AvgSN_A, aes(x=A,y=SNL,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_A %>% filter(A==which.max(AvgSN_A$SNL)),color="red")+
geom_point(data = AvgSN_A %>% filter(A!=which.max(AvgSN_A$SNL)),color="black")+
theme_classic()
gg2<-ggplot(AvgSN_B, aes(x=B,y=SNL,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_B %>% filter(B==which.max(AvgSN_B$SNL)),color="red")+
geom_point(data = AvgSN_B %>% filter(B!=which.max(AvgSN_B$SNL)),color="black")+
theme_classic()
gg3<-ggplot(AvgSN_C, aes(x=C,y=SNL,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_C %>% filter(C==which.max(AvgSN_C$SNL)),color="red")+
geom_point(data = AvgSN_C %>% filter(C!=which.max(AvgSN_C$SNL)),color="black")+
theme_classic()
gg4<-ggplot(AvgSN_D, aes(x=D,y=SNL,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_D %>% filter(D==which.max(AvgSN_D$SNL)),color="red")+
geom_point(data = AvgSN_D %>% filter(D!=which.max(AvgSN_D$SNL)),color="black")+
theme_classic()
#Graficamos Media ~ Factores
ggg1<-ggplot(media_A, aes(x=A,y=media,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = media_A %>% filter(A==which.max(media_A$media)),color="red")+
geom_point(data = media_A %>% filter(A!=which.max(media_A$media)),color="black")+
theme_classic()
ggg2<-ggplot(media_B, aes(x=B,y=media,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = media_B %>% filter(B==which.max(media_B$media)),color="red")+
geom_point(data = media_B %>% filter(B!=which.max(media_B$media)),color="black")+
theme_classic()
ggg3<-ggplot(media_C, aes(x=C,y=media,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = media_C %>% filter(C==which.max(media_C$media)),color="red")+
geom_point(data = media_C %>% filter(C!=which.max(media_C$media)),color="black")+
theme_classic()
ggg4<-ggplot(media_D, aes(x=D,y=media,group=1))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = media_D %>% filter(D==which.max(media_D$media)),color="red")+
geom_point(data = media_D %>% filter(D!=which.max(media_D$media)),color="black")+
theme_classic()
grid.arrange(gg1,gg2,gg3,gg4,ncol=2,nrow=2,bottom="SNL ~ Factores")
grid.arrange(ggg1,ggg2,ggg3,ggg4,ncol=2,nrow=2,bottom="Y ~ Factores")
Por conclusión las combinaciones de los niveles, que ofrecen el mejor desempeño de Y, para cada factor son:\(A = Medio\),\(B = Medio\),\(C = Alto\) y \(D = Bajo\). Sin embargo de los resultados de la tabla Anova, podemos obtener que los factores con mayor significancia son A y C, para le Taguchi \(L_9\) y para de los factores del Taguchi E y F contemplado como bloques, E y F. Para un \(\alpha=0.05\)
El artículo del cual se analizará los datos: An adaptative bacterial foraging optimization algorithm for solving the MRCPSP with discounted cash flows
Los datos resultantes del modelo computacional se encuentran en la Tabla 3 del artículo,los cuales se muestran a continuación:
# Lectura de los datos
datos<-read.table('C:/Users/FBA/OneDrive - Acesco/0. Personales/2. Profesional/20240416 - Maestria en Analítica de Datos/20240726 Diseño de Experimentos/Proyecto Final/Datos_Dominguez-Machado.txt', header = TRUE)
# recodificamos con los rangos 1:3, según lo indicador en Tabla 2. del artículo.
coded <- function(x) ifelse(x == min(x), 1,ifelse(x == max(x),3,2))
datos <- within(datos, {
coded_nBact = coded(nBact)
coded_Nc = coded(Nc)
coded_Nre = coded(Nre)
coded_Ned = coded(Ned)
coded_Pswarm = coded(Pswarm)
coded_Pcross = coded(Pcross)
coded_Pmut = coded(Pmut)
})
#Designamos factores
datos$nBact<-as.factor(datos$nBact)
datos$Nc<-as.factor(datos$Nc)
datos$Nre<-as.factor(datos$Nre)
datos$Ned<-as.factor(datos$Ned)
datos$Pswarm<-as.factor(datos$Pswarm)
datos$Pcross<-as.factor(datos$Pcross)
datos$Pmut<-as.factor(datos$Pmut)
print(datos) Experiment nBact Nc Nre Ned Pswarm Pcross Pmut AvgNPV coded_Pmut
1 1 10 6 10 10 0.1 0.9 0.9 -82192.94 3
2 2 10 6 10 15 0.5 0.1 0.5 -92610.33 2
3 3 10 4 15 5 0.5 0.9 0.1 -97486.04 1
4 4 10 2 5 10 0.5 0.5 0.9 -89516.52 3
5 5 10 2 5 5 0.1 0.1 0.1 -123536.66 1
6 6 10 2 5 15 0.9 0.9 0.5 -88533.90 2
7 7 10 4 15 15 0.1 0.5 0.5 -88789.31 2
8 8 10 6 10 5 0.9 0.5 0.1 -85040.58 1
9 9 10 4 15 10 0.9 0.1 0.9 -94020.51 3
10 10 30 2 15 10 0.1 0.9 0.5 -49722.65 2
11 11 30 4 10 10 0.5 0.5 0.5 -61358.33 2
12 12 30 2 15 5 0.9 0.5 0.9 -76807.57 3
13 13 30 2 15 15 0.5 0.1 0.1 -65278.19 1
14 14 30 4 10 5 0.1 0.1 0.9 -104694.10 3
15 15 30 6 5 15 0.1 0.5 0.1 -78679.51 1
16 16 30 6 5 10 0.9 0.1 0.5 -84569.60 2
17 17 30 4 10 15 0.9 0.9 0.1 -80373.05 1
18 18 30 6 5 5 0.5 0.9 0.9 -116035.01 3
19 19 50 2 10 15 0.1 0.5 0.9 -36236.18 3
20 20 50 6 15 10 0.5 0.5 0.1 -73876.07 1
21 21 50 2 10 10 0.9 0.1 0.1 -69788.72 1
22 22 50 6 15 5 0.1 0.1 0.5 -87026.80 2
23 23 50 4 5 10 0.1 0.9 0.1 -68129.99 1
24 24 50 4 5 5 0.9 0.5 0.5 -79919.31 2
25 25 50 6 15 15 0.9 0.9 0.9 -37661.26 3
26 26 50 2 10 5 0.5 0.9 0.5 -64536.93 2
27 27 50 4 5 15 0.5 0.1 0.9 -48600.91 3
coded_Pcross coded_Pswarm coded_Ned coded_Nre coded_Nc coded_nBact
1 3 1 2 2 3 1
2 1 2 3 2 3 1
3 3 2 1 3 2 1
4 2 2 2 1 1 1
5 1 1 1 1 1 1
6 3 3 3 1 1 1
7 2 1 3 3 2 1
8 2 3 1 2 3 1
9 1 3 2 3 2 1
10 3 1 2 3 1 2
11 2 2 2 2 2 2
12 2 3 1 3 1 2
13 1 2 3 3 1 2
14 1 1 1 2 2 2
15 2 1 3 1 3 2
16 1 3 2 1 3 2
17 3 3 3 2 2 2
18 3 2 1 1 3 2
19 2 1 3 2 1 3
20 2 2 2 3 3 3
21 1 3 2 2 1 3
22 1 1 1 3 3 3
23 3 1 2 1 2 3
24 2 3 1 1 2 3
25 3 3 3 3 3 3
26 3 2 1 2 1 3
27 1 2 3 1 2 3Para identificar los factores claves. Construimos tabla anova para las variables recodificadas, sin interacción debido a que un diseño taguchi sólo se pueden tener los efectos principales de los factores analizados ver:
fitfn<-aov(AvgNPV ~ nBact + Nc + Nre + Ned + Pswarm + Pcross + Pmut,data=datos)
fitpc<-summary(fitfn)
# Extraer la tabla ANOVA del resumen
aov_edit <- fitpc[[1]]
# Calcular la suma total de cuadrados
total_sum_sq <- sum(aov_edit$`Sum Sq`)
i<-1
# Calcular la contribución porcentual
aov_edit$"C(%)" <- aov_edit$`Sum Sq` / total_sum_sq * 100
aov_edit$"Rank" <- rank(-aov_edit$"C(%)",ties.method = "min")
print(aov_edit) Df Sum Sq Mean Sq F value Pr(>F) C(%) Rank
nBact 2 4244524138 2122262069 10.8015 0.00207 37.007 1
Nc 2 339701728 169850864 0.8645 0.44593 2.962 6
Nre 2 799780437 399890219 2.0353 0.17334 6.973 4
Ned 2 2854083881 1427041941 7.2631 0.00857 24.884 2
Pswarm 2 27764429 13882214 0.0707 0.93217 0.242 8
Pcross 2 647838820 323919410 1.6486 0.23303 5.648 5
Pmut 2 198049943 99024971 0.5040 0.61635 1.727 7
Residuals 12 2357738356 196478196 20.557 3Residual standard error: 1.4017^{4} on 12 degrees of freedom Multiple R-squared: 0.7944, Adjusted R-squared: 0.5546 F-statistic: 3.313 on 14 and 12 DF, P-value: 0.0221223
Los valores encontrados concuerdan con la Tabla 4 del artículo analizados. Encontramos que los factores clave nBacty $N_ed$ tienen efectos significativos más altos en la variable de respuesta AvgNPV. Coincidiendo con el % de contribución a la explicación del error C(%) más altos y los Pr(>F) de cada factor son estadisticamente significativos para un \(\alpha=0.05\).
Sin embargo, para el estudio en particular, aún cuando los demás factores no son estadisticamente significativos, se incluyen dentro de modelo de predicción porque pueden introducir nueva información al algoritmo
“Although the other factors are not statistically significant, they were kept as they may introduce new information or variations to the colony”, Machado - Domínguez
Cálculo de la Razón S/N para los datos del Artículo de Machado-Domínguez. Se utilizará la razón nominal \(SN_N\) teniendo presente que \(s^2 = MSE\). Lo deseable sería calcular el \(SN_L\) sin embargo se desconocen los resultados individuales de las corridas para cada combinación \((y_i)\)
Por lo cual la tabla de datos queda de la siguiente manera:
#Incorporar Columna SN_N en tabla de datos
datos$"SN_N"<- 10*log(((datos$AvgNPV)^2)/(summary.lm(fitfn)$sigma^2))
datos Experiment nBact Nc Nre Ned Pswarm Pcross Pmut AvgNPV coded_Pmut
1 1 10 6 10 10 0.1 0.9 0.9 -82192.94 3
2 2 10 6 10 15 0.5 0.1 0.5 -92610.33 2
3 3 10 4 15 5 0.5 0.9 0.1 -97486.04 1
4 4 10 2 5 10 0.5 0.5 0.9 -89516.52 3
5 5 10 2 5 5 0.1 0.1 0.1 -123536.66 1
6 6 10 2 5 15 0.9 0.9 0.5 -88533.90 2
7 7 10 4 15 15 0.1 0.5 0.5 -88789.31 2
8 8 10 6 10 5 0.9 0.5 0.1 -85040.58 1
9 9 10 4 15 10 0.9 0.1 0.9 -94020.51 3
10 10 30 2 15 10 0.1 0.9 0.5 -49722.65 2
11 11 30 4 10 10 0.5 0.5 0.5 -61358.33 2
12 12 30 2 15 5 0.9 0.5 0.9 -76807.57 3
13 13 30 2 15 15 0.5 0.1 0.1 -65278.19 1
14 14 30 4 10 5 0.1 0.1 0.9 -104694.10 3
15 15 30 6 5 15 0.1 0.5 0.1 -78679.51 1
16 16 30 6 5 10 0.9 0.1 0.5 -84569.60 2
17 17 30 4 10 15 0.9 0.9 0.1 -80373.05 1
18 18 30 6 5 5 0.5 0.9 0.9 -116035.01 3
19 19 50 2 10 15 0.1 0.5 0.9 -36236.18 3
20 20 50 6 15 10 0.5 0.5 0.1 -73876.07 1
21 21 50 2 10 10 0.9 0.1 0.1 -69788.72 1
22 22 50 6 15 5 0.1 0.1 0.5 -87026.80 2
23 23 50 4 5 10 0.1 0.9 0.1 -68129.99 1
24 24 50 4 5 5 0.9 0.5 0.5 -79919.31 2
25 25 50 6 15 15 0.9 0.9 0.9 -37661.26 3
26 26 50 2 10 5 0.5 0.9 0.5 -64536.93 2
27 27 50 4 5 15 0.5 0.1 0.9 -48600.91 3
coded_Pcross coded_Pswarm coded_Ned coded_Nre coded_Nc coded_nBact SN_N
1 3 1 2 2 3 1 35.37587
2 1 2 3 2 3 1 37.76250
3 3 2 1 3 2 1 38.78867
4 2 2 2 1 1 1 37.08295
5 1 1 1 1 1 1 43.52524
6 3 3 3 1 1 1 36.86220
7 2 1 3 3 2 1 36.91981
8 2 3 1 2 3 1 36.05706
9 1 3 2 3 2 1 38.06474
10 3 1 2 3 1 2 25.32370
11 2 2 2 2 2 2 29.52910
12 2 3 1 3 1 2 34.02055
13 1 2 3 3 1 2 30.76765
14 1 1 1 2 2 2 40.21534
15 2 1 3 1 3 2 34.50214
16 1 3 2 1 3 2 35.94598
17 3 3 3 2 2 2 34.92806
18 3 2 1 1 3 2 42.27232
19 2 1 3 2 1 3 18.99565
20 2 2 2 3 3 3 33.24226
21 1 3 2 2 1 3 32.10393
22 1 1 1 3 3 3 36.51881
23 3 1 2 1 2 3 31.62284
24 2 3 1 1 2 3 34.81484
25 3 3 3 3 3 3 19.76712
26 3 2 1 2 1 3 30.53924
27 1 2 3 1 2 3 24.86733Calculamos el \(SN_N\) promedio para cada factor para cada nivel. Por ejemplo, el promedio de \(SN_N\), para el factor \(nBact\) en el nivel 1 es igual a \(SN_N(Level=1)=\) (35.38+ 37.76+38.79+37.08+43.53+36.86+36.92+36.06+38.06)/9 = 37.83
De forma que tenemos los siguientes promedios para \(SN_N\) y \(AvgNPV\) por cada factor, por cada nivel:
#Calculamos SN_N por factor por nivel
AvgSN_nBact<-aggregate(SN_N~coded_nBact,data=datos,mean)
AvgSN_Nc<-aggregate(SN_N~coded_Nc,data=datos,mean)
AvgSN_Nre<-aggregate(SN_N~coded_Nre,data=datos,mean)
AvgSN_Ned<-aggregate(SN_N~coded_Ned,data=datos,mean)
AvgSN_Pswarm<-aggregate(SN_N~coded_Pswarm,data=datos,mean)
AvgSN_Pcross<-aggregate(SN_N~coded_Pcross,data=datos,mean)
AvgSN_Pmut<-aggregate(SN_N~coded_Pmut,data=datos,mean)
AvgSN_nBact coded_nBact SN_N
1 1 37.82656
2 2 34.16721
3 3 29.16356AvgSN_Nc coded_Nc SN_N
1 1 32.13568
2 2 34.41675
3 3 34.60490AvgSN_Nre coded_Nre SN_N
1 1 35.72176
2 2 32.83408
3 3 32.60148AvgSN_Ned coded_Ned SN_N
1 1 37.41690
2 2 33.14349
3 3 30.59694AvgSN_Pswarm coded_Pswarm SN_N
1 1 33.66660
2 2 33.87245
3 3 33.61828AvgSN_Pcross coded_Pcross SN_N
1 1 35.53017
2 2 32.79604
3 3 32.83111AvgSN_Pmut coded_Pmut SN_N
1 1 35.05976
2 2 33.80180
3 3 32.29576#Calculamos Promedio de AvgNPV por factor por nivel
AvgNPV_nBact<-aggregate(AvgNPV~coded_nBact,data=datos,mean)
AvgNPV_Nc<-aggregate(AvgNPV~coded_Nc,data=datos,mean)
AvgNPV_Nre<-aggregate(AvgNPV~coded_Nre,data=datos,mean)
AvgNPV_Ned<-aggregate(AvgNPV~coded_Ned,data=datos,mean)
AvgNPV_Pswarm<-aggregate(AvgNPV~coded_Pswarm,data=datos,mean)
AvgNPV_Pcross<-aggregate(AvgNPV~coded_Pcross,data=datos,mean)
AvgNPV_Pmut<-aggregate(AvgNPV~coded_Pmut,data=datos,mean)
AvgNPV_nBact coded_nBact AvgNPV
1 1 -93525.20
2 2 -79724.22
3 3 -62864.02AvgNPV_Nc coded_Nc AvgNPV
1 1 -73773.04
2 2 -80374.62
3 3 -81965.79AvgNPV_Nre coded_Nre AvgNPV
1 1 -86391.27
2 2 -75203.46
3 3 -74518.71AvgNPV_Ned coded_Ned AvgNPV
1 1 -92787.00
2 2 -74797.26
3 3 -68529.18AvgNPV_Pswarm coded_Pswarm AvgNPV
1 1 -79889.79
2 2 -78810.93
3 3 -77412.72AvgNPV_Pcross coded_Pcross AvgNPV
1 1 -85569.54
2 2 -74469.26
3 3 -76074.64AvgNPV_Pmut coded_Pmut AvgNPV
1 1 -82465.42
2 2 -77451.91
3 3 -76196.11Debido a que no se puede utilizar \(SN_L\) para calcular estimar la combinación de niveles de factores que producen el máximo \(AvgNPV\), partiremos del \(SN_N\) para estimar los niveles de los factores que producen el máximo \(AvgNPV\). El cual se obtiene donde el promedio de los \(SN_N\) es el mínimo, en cada nivel por factor.
De manera similar se utiliza el promedio del \(AvgNPV\) para estimar la combinación de niveles de cada factor que producen el máximo de \(AvgNPV\). El cual se obtiene donde el promedio de los \(AvgNPV\) es el máximo, en cada nivel por factor.
Para efectos gráficos se idenficó con el color Rojo los puntos donde el \(SN_N\) es el mínimo G1 y \(AvgNPV\) es el máximo G2.
#Graficamos SN_N ~ Factores
g1<-ggplot(AvgSN_nBact, aes(x=coded_nBact,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_nBact %>% filter(coded_nBact==which.min(AvgSN_nBact$SN_N)),color="red")+
geom_point(data = AvgSN_nBact %>% filter(coded_nBact!=which.min(AvgSN_nBact$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_nBact$coded_nBact))
g2<-ggplot(AvgSN_Nc, aes(x=coded_Nc,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Nc %>% filter(coded_Nc==which.min(AvgSN_Nc$SN_N)),color="red")+
geom_point(data = AvgSN_Nc %>% filter(coded_Nc!=which.min(AvgSN_Nc$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Nc$coded_Nc))
g3<-ggplot(AvgSN_Nre, aes(x=coded_Nre,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Nre %>% filter(coded_Nre==which.min(AvgSN_Nre$SN_N)),color="red")+
geom_point(data = AvgSN_Nre %>% filter(coded_Nre!=which.min(AvgSN_Nre$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Nre$coded_Nre))
g4<-ggplot(AvgSN_Ned, aes(x=coded_Ned,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Ned %>% filter(coded_Ned==which.min(AvgSN_Ned$SN_N)),color="red")+
geom_point(data = AvgSN_Ned %>% filter(coded_Ned!=which.min(AvgSN_Ned$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Ned$coded_Ned))
g5<-ggplot(AvgSN_Pswarm, aes(x=coded_Pswarm,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Pswarm %>% filter(coded_Pswarm==which.min(AvgSN_Pswarm$SN_N)),color="red")+
geom_point(data = AvgSN_Pswarm %>% filter(coded_Pswarm!=which.min(AvgSN_Pswarm$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Pswarm$coded_Pswarm))
g6<-ggplot(AvgSN_Pcross, aes(x=coded_Pcross,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Pcross %>% filter(coded_Pcross==which.min(AvgSN_Pcross$SN_N)),color="red")+
geom_point(data = AvgSN_Pcross %>% filter(coded_Pcross!=which.min(AvgSN_Pcross$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Pcross$coded_Pcross))
g7<-ggplot(AvgSN_Pmut, aes(x=coded_Pmut,y=SN_N))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgSN_Pmut %>% filter(coded_Pmut==which.min(AvgSN_Pmut$SN_N)),color="red")+
geom_point(data = AvgSN_Pmut %>% filter(coded_Pmut!=which.min(AvgSN_Pmut$SN_N)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgSN_Pmut$coded_Pmut))
#Graficamos AvgNVP ~ Factores
gg1<-ggplot(AvgNPV_nBact, aes(x=coded_nBact,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_nBact %>% filter(coded_nBact==which.max(AvgNPV_nBact$AvgNPV)),color="red")+
geom_point(data = AvgNPV_nBact %>% filter(coded_nBact!=which.max(AvgNPV_nBact$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_nBact$coded_nBact))
gg2<-ggplot(AvgNPV_Nc, aes(x=coded_Nc,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Nc %>% filter(coded_Nc==which.max(AvgNPV_Nc$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Nc %>% filter(coded_Nc!=which.max(AvgNPV_Nc$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Nc$coded_Nc))
gg3<-ggplot(AvgNPV_Nre, aes(x=coded_Nre,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Nre %>% filter(coded_Nre==which.max(AvgNPV_Nre$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Nre %>% filter(coded_Nre!=which.max(AvgNPV_Nre$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Nre$coded_Nre))
gg4<-ggplot(AvgNPV_Ned, aes(x=coded_Ned,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Ned %>% filter(coded_Ned==which.max(AvgNPV_Ned$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Ned %>% filter(coded_Ned!=which.max(AvgNPV_Ned$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Ned$coded_Ned))
gg5<-ggplot(AvgNPV_Pswarm, aes(x=coded_Pswarm,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Pswarm %>% filter(coded_Pswarm==which.max(AvgNPV_Pswarm$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Pswarm %>% filter(coded_Pswarm!=which.max(AvgNPV_Pswarm$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Pswarm$coded_Pswarm))
gg6<-ggplot(AvgNPV_Pcross, aes(x=coded_Pcross,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Pcross %>% filter(coded_Pcross==which.max(AvgNPV_Pcross$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Pcross %>% filter(coded_Pcross!=which.max(AvgNPV_Pcross$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Pcross$coded_Pcross))
gg7<-ggplot(AvgNPV_Pmut, aes(x=coded_Pmut,y=AvgNPV))+
geom_smooth(method = "lm",formula = y ~ x + I(x^2),se= FALSE)+
geom_point(data = AvgNPV_Pmut %>% filter(coded_Pmut==which.max(AvgNPV_Pmut$AvgNPV)),color="red")+
geom_point(data = AvgNPV_Pmut %>% filter(coded_Pmut!=which.max(AvgNPV_Pmut$AvgNPV)),color="black")+
theme_classic()+
scale_x_continuous(breaks=unique(AvgNPV_Pmut$coded_Pmut))
G1<-grid.arrange(g1,g2,g3,g4,g5,g6,g7,ncol=4,nrow=2,bottom="Efectos SN_N")
G2<-grid.arrange(gg1,gg2,gg3,gg4,gg5,gg6,gg7,ncol=4,nrow=2,bottom="Efectos AvgNPV")
De forma que el conjunto de parámetros óptimos que maximizan el NPV cuando se usa el algoritmo ABFOson:
Opt_nBact<-fitfn[[10]][[1]][which.max(AvgNPV_nBact$AvgNPV)]
Opt_Nc<-fitfn[[10]][[2]][which.max(AvgNPV_Nc$AvgNPV)]
Opt_Nre<-fitfn[[10]][[3]][which.max(AvgNPV_Nre$AvgNPV)]
Opt_Ned<-fitfn[[10]][[4]][which.max(AvgNPV_Ned$AvgNPV)]
Opt_Pswarm<-fitfn[[10]][[5]][which.max(AvgNPV_Pswarm$AvgNPV)]
Opt_Pcross<-fitfn[[10]][[6]][which.max(AvgNPV_Pcross$AvgNPV)]
Opt_Pmut<-fitfn[[10]][[7]][which.max(AvgNPV_Pmut$AvgNPV)]\(nBact =\) 50
\(N_c =\) 2
\(N_{re}=\) 15
\(N_{ed}=\) 15
\(P_{swarm}=\) 0.9
\(P_{cross}=\) 0.5
\(P_{mut}=\) 0.9
Rangos <- rename(AvgNPV_nBact,Levels=coded_nBact,nBact=AvgNPV)
Rangos$Nc <- AvgNPV_Nc$AvgNPV
Rangos$Nre <- AvgNPV_Nre$AvgNPV
Rangos$Ned <- AvgNPV_Ned$AvgNPV
Rangos$Pswarm <- AvgNPV_Pswarm$AvgNPV
Rangos$Pcross <- AvgNPV_Pcross$AvgNPV
Rangos$Pmut <- AvgNPV_Pmut$AvgNPV
Rangos<-rbind(Rangos, data.frame(Levels="Delta",
nBact=(max(Rangos$nBact)-min(Rangos$nBact)),
Nc=(max(Rangos$Nc)-min(Rangos$Nc)),
Nre=(max(Rangos$Nre)-min(Rangos$Nre)),
Ned=(max(Rangos$Ned)-min(Rangos$Ned)),
Pswarm=(max(Rangos$Pswarm)-min(Rangos$Pswarm)),
Pcross=(max(Rangos$Pcross)-min(Rangos$Pcross)),
Pmut=(max(Rangos$Pmut)-min(Rangos$Pmut))))
#Crear Ranking por la fila Delta "[,4]
Ranking<-t(apply(Rangos,1,rank)[,4])
Rangos <- rbind(Rangos,data.frame(Ranking))
Rangos[5,1]<-"Ranking"
Rangos Levels nBact Nc Nre Ned Pswarm Pcross
1 1 -93525.20 -73773.036 -86391.27 -92787.00 -79889.793 -85569.54
2 2 -79724.22 -80374.617 -75203.46 -74797.26 -78810.926 -74469.26
3 3 -62864.02 -81965.789 -74518.71 -68529.18 -77412.722 -76074.64
4 Delta 30661.18 8192.753 11872.56 24257.82 2477.071 11100.27
5 Ranking 7.00 3.000 5.00 6.00 1.000 4.00
Pmut
1 -82465.423
2 -77451.907
3 -76196.111
4 6269.312
5 2.000La fila “Delta” representa la diferencia máxima entre las respuestas de nivel. Estas diferencias se clasifican de 1 a 7, siendo 7 el rango para el valor máximo de AvgNPV. Puede ser consultado en la Tabla 5 ## Conclusiones
El método taguchi permite simplificar la cantidad de experimentos realizados. Logrando reducir significativamente el numero de combinaciones de factores a ejecutar. Adicionalmente, provee un método para determinar los parámetros preferidos mediante el signal-to-noiseo SNdonde los niveles de cada factor son optimos para maximizar la relación SN
También se puede percibir, que los niveles optimos para cada factor seleccionados, bajo la metodología de “Razón promedio” y a través de las gráficos de `SN~ Factor, coinciden entre sí.
Machado-Domínguez, L.F., Paternina-Arboleda, C.D., Vélez, J.I. et al. An adaptative bacterial foraging optimization algorithm for solving the MRCPSP with discounted cash flows. TOP 30, 221–248 (2022). Click