#Numero de epocas
Tmax = 3

#Estados 
estados = c('Excelente','Bueno','Promedio','Malo')

#Decisiones
decisiones = c("Reemplazar",'No reemplazar')

#Retornos inmediatos

datos_retornos = c(-1e7,100,
                   -100,80,
                   -100,50,
                   -100,10)

retorno_inmediato = matrix(datos_retornos,byrow = T, nrow = 4, ncol = 2)
dimnames(retorno_inmediato) = list(estados,decisiones)


#Estado futuro - Matrices de probabilidad

#Decisión de reemplazar
datos_Reemplazar = c(0  ,0  ,0,0,
                     0.7,0.3,0,0,
                     0.7,0.3,0,0,
                     0.7,0.3,0,0)

p_Reemplazar = matrix(datos_Reemplazar, byrow = T, ncol = 4, nrow = 4)
dimnames(p_Reemplazar) = list(estados,estados)


#Decisión de NO reemplazar

datos_Noreemplazar = c(0.7,0.3,0,0,
                       0,0.7,0.3,0,
                       0,0,0.6,0.4,
                       0,0,0,1)

p_NO_reemplazar = matrix(datos_Noreemplazar, byrow = T, ncol = 4, nrow = 4)
dimnames(p_NO_reemplazar) = list(estados,estados)


#Matriz con las ecuaciones de Bellmann
Ft_optimo = matrix(0,nrow = length(estados), ncol = Tmax)
dimnames(Ft_optimo) = list(estados,seq(1:Tmax))


#Matriz con las decisiones optimas
Mat_Dec_Optimo = matrix(0,nrow = length(estados), ncol = Tmax)
dimnames(Mat_Dec_Optimo) = list(estados,seq(1:Tmax))

#---------------------Recursión hacia atras de la semana 3-----------------------------

#Crear las funciones de Bellman f_3(i)
f_i = matrix(0, nrow = length(estados), ncol = length(decisiones))
dimnames(f_i) = list(estados,decisiones)

#En la ultima epoca la ecuación de Bellman es el retorno inmediato
f_i = retorno_inmediato


#Escoger la mejor decisión para cada estado
Ft_optimo[,Tmax] = apply(f_i,1,max)
#apply es una función que aplica una función especificada a las filas 
#o columnas de una matriz o DataFrame.

#f_i es la matriz o DataFrame a la que se aplica la función.

#1 indica el margen a lo largo del cual se aplica la función. 
#En este caso, 1 indica que la función debe aplicarse a las filas. 
#Si fuera 2, la función se aplicaría a las columnas.

#max es la función que se va a aplicar.

#Por lo tanto, apply(f_i, 1, max) aplicará la función 
#max a cada fila de la matriz o DataFrame f_i. 
#El resultado será un vector que contiene el valor máximo de cada fila.

Mat_Dec_Optimo[,Tmax] = decisiones[apply(f_i,1,which.max)]

#----------------------Recursion hacia atras------------------------------#


for(t in (Tmax-1):1){
  
  # Crear las funciones de Bellman - guarda la ecuacion
  f_i<- matrix(0,nrow=length(estados),ncol=length(decisiones))
  dimnames(f_i) <- list(estados,decisiones)
  
  f_i[,"Reemplazar"] <- retorno_inmediato[,"Reemplazar"] + p_Reemplazar%*%Ft_optimo[,t+1]
  f_i[,"No reemplazar"] <- retorno_inmediato[,"No reemplazar"] + p_NO_reemplazar%*%Ft_optimo[,t+1]
  
  # Maximo
  Ft_optimo[,t] <- apply(f_i, 1, max)
  Mat_Dec_Optimo[,t]<- decisiones[apply(f_i, 1, which.max)]
  
}


# Mapa de Calor -----------------------------------------------------------


library(magrittr)
library(dplyr)
library(tidyr)
library(ggplot2)

Mat_Dec_Optimo <- data.frame(Mat_Dec_Optimo)
dimnames(Mat_Dec_Optimo) <- list(estados,seq(1:Tmax))

# Unir todas las épocas y decisiones
Mat_Dec_Optimo <- gather(Mat_Dec_Optimo, Epocas, Decision)

# rep genera una lista de valores iguales a los estados
Mat_Dec_Optimo$Estado <- rep(estados,Tmax)

# Convertir a número
Mat_Dec_Optimo$Epocas <- as.numeric(Mat_Dec_Optimo$Epocas)

# Graficar
ggplot(data = Mat_Dec_Optimo, aes(x = Epocas, y = Estado, fill = Decision)) + geom_tile()+ ylim("Malo","Promedio","Bueno","Excelente") + labs(x = "Epocas")
LS0tDQp0aXRsZTogIlNEUCINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCg0KYGBge3J9DQoNCiNOdW1lcm8gZGUgZXBvY2FzDQpUbWF4ID0gMw0KDQojRXN0YWRvcyANCmVzdGFkb3MgPSBjKCdFeGNlbGVudGUnLCdCdWVubycsJ1Byb21lZGlvJywnTWFsbycpDQoNCiNEZWNpc2lvbmVzDQpkZWNpc2lvbmVzID0gYygiUmVlbXBsYXphciIsJ05vIHJlZW1wbGF6YXInKQ0KDQojUmV0b3Jub3MgaW5tZWRpYXRvcw0KDQpkYXRvc19yZXRvcm5vcyA9IGMoLTFlNywxMDAsDQogICAgICAgICAgICAgICAgICAgLTEwMCw4MCwNCiAgICAgICAgICAgICAgICAgICAtMTAwLDUwLA0KICAgICAgICAgICAgICAgICAgIC0xMDAsMTApDQoNCnJldG9ybm9faW5tZWRpYXRvID0gbWF0cml4KGRhdG9zX3JldG9ybm9zLGJ5cm93ID0gVCwgbnJvdyA9IDQsIG5jb2wgPSAyKQ0KZGltbmFtZXMocmV0b3Jub19pbm1lZGlhdG8pID0gbGlzdChlc3RhZG9zLGRlY2lzaW9uZXMpDQoNCg0KI0VzdGFkbyBmdXR1cm8gLSBNYXRyaWNlcyBkZSBwcm9iYWJpbGlkYWQNCg0KI0RlY2lzacOzbiBkZSByZWVtcGxhemFyDQpkYXRvc19SZWVtcGxhemFyID0gYygwICAsMCAgLDAsMCwNCiAgICAgICAgICAgICAgICAgICAgIDAuNywwLjMsMCwwLA0KICAgICAgICAgICAgICAgICAgICAgMC43LDAuMywwLDAsDQogICAgICAgICAgICAgICAgICAgICAwLjcsMC4zLDAsMCkNCg0KcF9SZWVtcGxhemFyID0gbWF0cml4KGRhdG9zX1JlZW1wbGF6YXIsIGJ5cm93ID0gVCwgbmNvbCA9IDQsIG5yb3cgPSA0KQ0KZGltbmFtZXMocF9SZWVtcGxhemFyKSA9IGxpc3QoZXN0YWRvcyxlc3RhZG9zKQ0KDQoNCiNEZWNpc2nDs24gZGUgTk8gcmVlbXBsYXphcg0KDQpkYXRvc19Ob3JlZW1wbGF6YXIgPSBjKDAuNywwLjMsMCwwLA0KICAgICAgICAgICAgICAgICAgICAgICAwLDAuNywwLjMsMCwNCiAgICAgICAgICAgICAgICAgICAgICAgMCwwLDAuNiwwLjQsDQogICAgICAgICAgICAgICAgICAgICAgIDAsMCwwLDEpDQoNCnBfTk9fcmVlbXBsYXphciA9IG1hdHJpeChkYXRvc19Ob3JlZW1wbGF6YXIsIGJ5cm93ID0gVCwgbmNvbCA9IDQsIG5yb3cgPSA0KQ0KZGltbmFtZXMocF9OT19yZWVtcGxhemFyKSA9IGxpc3QoZXN0YWRvcyxlc3RhZG9zKQ0KDQoNCiNNYXRyaXogY29uIGxhcyBlY3VhY2lvbmVzIGRlIEJlbGxtYW5uDQpGdF9vcHRpbW8gPSBtYXRyaXgoMCxucm93ID0gbGVuZ3RoKGVzdGFkb3MpLCBuY29sID0gVG1heCkNCmRpbW5hbWVzKEZ0X29wdGltbykgPSBsaXN0KGVzdGFkb3Msc2VxKDE6VG1heCkpDQoNCg0KI01hdHJpeiBjb24gbGFzIGRlY2lzaW9uZXMgb3B0aW1hcw0KTWF0X0RlY19PcHRpbW8gPSBtYXRyaXgoMCxucm93ID0gbGVuZ3RoKGVzdGFkb3MpLCBuY29sID0gVG1heCkNCmRpbW5hbWVzKE1hdF9EZWNfT3B0aW1vKSA9IGxpc3QoZXN0YWRvcyxzZXEoMTpUbWF4KSkNCg0KIy0tLS0tLS0tLS0tLS0tLS0tLS0tLVJlY3Vyc2nDs24gaGFjaWEgYXRyYXMgZGUgbGEgc2VtYW5hIDMtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLQ0KDQojQ3JlYXIgbGFzIGZ1bmNpb25lcyBkZSBCZWxsbWFuIGZfMyhpKQ0KZl9pID0gbWF0cml4KDAsIG5yb3cgPSBsZW5ndGgoZXN0YWRvcyksIG5jb2wgPSBsZW5ndGgoZGVjaXNpb25lcykpDQpkaW1uYW1lcyhmX2kpID0gbGlzdChlc3RhZG9zLGRlY2lzaW9uZXMpDQoNCiNFbiBsYSB1bHRpbWEgZXBvY2EgbGEgZWN1YWNpw7NuIGRlIEJlbGxtYW4gZXMgZWwgcmV0b3JubyBpbm1lZGlhdG8NCmZfaSA9IHJldG9ybm9faW5tZWRpYXRvDQoNCg0KI0VzY29nZXIgbGEgbWVqb3IgZGVjaXNpw7NuIHBhcmEgY2FkYSBlc3RhZG8NCkZ0X29wdGltb1ssVG1heF0gPSBhcHBseShmX2ksMSxtYXgpDQojYXBwbHkgZXMgdW5hIGZ1bmNpw7NuIHF1ZSBhcGxpY2EgdW5hIGZ1bmNpw7NuIGVzcGVjaWZpY2FkYSBhIGxhcyBmaWxhcyANCiNvIGNvbHVtbmFzIGRlIHVuYSBtYXRyaXogbyBEYXRhRnJhbWUuDQoNCiNmX2kgZXMgbGEgbWF0cml6IG8gRGF0YUZyYW1lIGEgbGEgcXVlIHNlIGFwbGljYSBsYSBmdW5jacOzbi4NCg0KIzEgaW5kaWNhIGVsIG1hcmdlbiBhIGxvIGxhcmdvIGRlbCBjdWFsIHNlIGFwbGljYSBsYSBmdW5jacOzbi4gDQojRW4gZXN0ZSBjYXNvLCAxIGluZGljYSBxdWUgbGEgZnVuY2nDs24gZGViZSBhcGxpY2Fyc2UgYSBsYXMgZmlsYXMuIA0KI1NpIGZ1ZXJhIDIsIGxhIGZ1bmNpw7NuIHNlIGFwbGljYXLDrWEgYSBsYXMgY29sdW1uYXMuDQoNCiNtYXggZXMgbGEgZnVuY2nDs24gcXVlIHNlIHZhIGEgYXBsaWNhci4NCg0KI1BvciBsbyB0YW50bywgYXBwbHkoZl9pLCAxLCBtYXgpIGFwbGljYXLDoSBsYSBmdW5jacOzbiANCiNtYXggYSBjYWRhIGZpbGEgZGUgbGEgbWF0cml6IG8gRGF0YUZyYW1lIGZfaS4gDQojRWwgcmVzdWx0YWRvIHNlcsOhIHVuIHZlY3RvciBxdWUgY29udGllbmUgZWwgdmFsb3IgbcOheGltbyBkZSBjYWRhIGZpbGEuDQoNCk1hdF9EZWNfT3B0aW1vWyxUbWF4XSA9IGRlY2lzaW9uZXNbYXBwbHkoZl9pLDEsd2hpY2gubWF4KV0NCg0KIy0tLS0tLS0tLS0tLS0tLS0tLS0tLS1SZWN1cnNpb24gaGFjaWEgYXRyYXMtLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0jDQoNCg0KZm9yKHQgaW4gKFRtYXgtMSk6MSl7DQogIA0KICAjIENyZWFyIGxhcyBmdW5jaW9uZXMgZGUgQmVsbG1hbiAtIGd1YXJkYSBsYSBlY3VhY2lvbg0KICBmX2k8LSBtYXRyaXgoMCxucm93PWxlbmd0aChlc3RhZG9zKSxuY29sPWxlbmd0aChkZWNpc2lvbmVzKSkNCiAgZGltbmFtZXMoZl9pKSA8LSBsaXN0KGVzdGFkb3MsZGVjaXNpb25lcykNCiAgDQogIGZfaVssIlJlZW1wbGF6YXIiXSA8LSByZXRvcm5vX2lubWVkaWF0b1ssIlJlZW1wbGF6YXIiXSArIHBfUmVlbXBsYXphciUqJUZ0X29wdGltb1ssdCsxXQ0KICBmX2lbLCJObyByZWVtcGxhemFyIl0gPC0gcmV0b3Jub19pbm1lZGlhdG9bLCJObyByZWVtcGxhemFyIl0gKyBwX05PX3JlZW1wbGF6YXIlKiVGdF9vcHRpbW9bLHQrMV0NCiAgDQogICMgTWF4aW1vDQogIEZ0X29wdGltb1ssdF0gPC0gYXBwbHkoZl9pLCAxLCBtYXgpDQogIE1hdF9EZWNfT3B0aW1vWyx0XTwtIGRlY2lzaW9uZXNbYXBwbHkoZl9pLCAxLCB3aGljaC5tYXgpXQ0KICANCn0NCg0KDQojIE1hcGEgZGUgQ2Fsb3IgLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0NCg0KDQpsaWJyYXJ5KG1hZ3JpdHRyKQ0KbGlicmFyeShkcGx5cikNCmxpYnJhcnkodGlkeXIpDQpsaWJyYXJ5KGdncGxvdDIpDQoNCk1hdF9EZWNfT3B0aW1vIDwtIGRhdGEuZnJhbWUoTWF0X0RlY19PcHRpbW8pDQpkaW1uYW1lcyhNYXRfRGVjX09wdGltbykgPC0gbGlzdChlc3RhZG9zLHNlcSgxOlRtYXgpKQ0KDQojIFVuaXIgdG9kYXMgbGFzIMOpcG9jYXMgeSBkZWNpc2lvbmVzDQpNYXRfRGVjX09wdGltbyA8LSBnYXRoZXIoTWF0X0RlY19PcHRpbW8sIEVwb2NhcywgRGVjaXNpb24pDQoNCiMgcmVwIGdlbmVyYSB1bmEgbGlzdGEgZGUgdmFsb3JlcyBpZ3VhbGVzIGEgbG9zIGVzdGFkb3MNCk1hdF9EZWNfT3B0aW1vJEVzdGFkbyA8LSByZXAoZXN0YWRvcyxUbWF4KQ0KDQojIENvbnZlcnRpciBhIG7Dum1lcm8NCk1hdF9EZWNfT3B0aW1vJEVwb2NhcyA8LSBhcy5udW1lcmljKE1hdF9EZWNfT3B0aW1vJEVwb2NhcykNCg0KIyBHcmFmaWNhcg0KZ2dwbG90KGRhdGEgPSBNYXRfRGVjX09wdGltbywgYWVzKHggPSBFcG9jYXMsIHkgPSBFc3RhZG8sIGZpbGwgPSBEZWNpc2lvbikpICsgZ2VvbV90aWxlKCkrIHlsaW0oIk1hbG8iLCJQcm9tZWRpbyIsIkJ1ZW5vIiwiRXhjZWxlbnRlIikgKyBsYWJzKHggPSAiRXBvY2FzIikNCg0KDQpgYGANCg0K