GENERANDO UN ALGORITMO ID3 EN VBA

Hola a todos:

Hace varias semanas que comencé a programar en VBA un algoritmo ID3 (Inducción mediante árboles de decisión). Este tipo de algoritmos se desarrollan en el campo de la Inteligencia Artificial y se engloban en los denominados algoritmos de aprendizaje.

El interés de realizar esta programación radica en la finalizad del algoritmo, es decir, su objetivo es (muy resumidamente) la búsqueda de reglas en un conjunto de ejemplos que nos van a permitir tomar decisiones, (fundamentalmente boolenas, o dicotómicas, ej: si o no).

En Internet tenéis muchos ejemplos donde se muestra el cálculo del algoritmo, en concreto os dejo este PDF: APRENDIZAJE INDUCTIVO. ÁRBOLES Y REGLAS DE DECISIÓN  (fuente: Dpto. Ciencias de Computación e Inteligencia Artificial Universidad de Sevilla), dado que contiene dos ejemplos de cálculo bien explicados.

No voy a escribir un post acerca del cálculo teórico del algoritmo (esto lo encontraréis en el PDF y en otros recursos similares en la red), me centraré en la programación del cálculo y sus resultados.

Para ilustrar el cálculo, empezaré mostrando el conjunto de ejemplos que nos servirán de base para generar el algoritmo:

GENERANDO UN ALGORITMO ID3 EN VBA

Efectivamente, se trata de un conjunto de elementos mediante los cuales tomamos la decisión de jugar o no jugar al tenis. El ejercicio se trata de determinar que nodo o variable principal será la determinante a la hora de tomar la decisión y luego el peso que tendrán el resto de atributos.

Para hallar el nodo principal, necesitamos calcular la entropía inicial sobre la que basar nuestros cálculos, esto lo haremos con esta parte del código:

Option Explicit
Sub ALGORITMO_ID3()
'AUTOR: SEGUNDO MIGUÉNS
'SITIO WEB: WWW.EXCELSIGNUM.COM
'------------------------
'CÁLCULO ENTROPIA INICIAL
'------------------------
'Variables utilizadas
'-----------------------------------------------------------
Dim fin As Long, final As Long
Dim i As Long, a As Long
Dim apalabra As String, sCadena_A As String, unicos_A As String
Dim oDic As Object
Dim matriz, nArgum
Dim sEntropia As Double, Entropia As Double
'-----------------------------------------------------------
With Sheets("DATOS")
fin = Application.CountA(.Range("1:1"))
final = Application.CountA(.Range("A:A"))
For i = 2 To final
apalabra = apalabra & "|" & .Cells(i, fin)
Next i
sCadena_A = Trim(Mid(apalabra, 2, Len(apalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_A, "|")
For a = 0 To UBound(matriz)
If Not oDic.Exists(matriz(a)) Then oDic.Add matriz(a), matriz(a)
Next a
unicos_A = Join(oDic.Keys, "|")
For Each nArgum In Split(unicos_A, "|")
sEntropia = -(UBound(Split(sCadena_A, nArgum)) / (final - 1)) * Application.WorksheetFunction.Log(UBound(Split(sCadena_A, nArgum)) / (final - 1), 2)
Entropia = Entropia + sEntropia
Next nArgum
Sheets("RESULTADOS").Cells(1, 1) = "ENTROPÍA INICIAL"
Sheets("RESULTADOS").Cells(2, 1) = Entropia

Una vez que tenemos el resultado de la entropía inicial, que nos indicará el grado de homogeneidad de los datos, (donde “0” es totalmente homogéneo y “1” lo contrario). Para este caso el resultado es de 0,940.

El siguiente paso es la selección del atributo para el nodo raíz. Para ello, seguiremos con esta parte del código:

'----------------------------------
'SELECCION ATRIBUTO GANANCIA MAXIMA
'----------------------------------
'Variables utilizadas
'-----------------------------------------------------------------------------------------------------------
Dim n As Long, b As Long, d As Long, columna As Long, Contador As Long, g As Long, s As Long
Dim sCadena_B As String, unicos_B As String, sCadena_ganancia As String
Dim Control_bpalabra As String, Control_cpalabra As String, atributo_Ganancia As String, sCadena_C As String
Dim bpalabra, cpalabra, nGanancia, Ganancia_max As String, valor As String
Dim parte As Double, total As Double, calculo_1 As Double, numerador As Double, denominador As Double
Dim Resultado_1 As Double, pGanancia As Double, Acu_pGanancia As Double, ganancia As Double
Dim listMatriz_A As Object, resultado
'-----------------------------------------------------------------------------------------------------------
For n = 2 To fin - 1
For i = 2 To final
bpalabra = bpalabra & "|" & .Cells(i, n)
Next i
sCadena_B = Trim(Mid(bpalabra, 2, Len(bpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_B, "|")
For b = 0 To UBound(matriz)
If Not oDic.Exists(matriz(b)) Then oDic.Add matriz(b), matriz(b)
Next b
unicos_B = Join(oDic.Keys, "|")
For Each bpalabra In Split(unicos_B, "|")
Control_bpalabra = bpalabra
For Each cpalabra In Split(unicos_A, "|")
Control_cpalabra = cpalabra
parte = Application.WorksheetFunction.CountIfs(.Range(.Cells(2, n), .Cells(final, n)), bpalabra, .Range(.Cells(2, fin), .Cells(final, fin)), cpalabra)
total = Application.WorksheetFunction.CountIf(.Range(.Cells(2, n), .Cells(final, n)), bpalabra)
If parte = "0" Then
Resultado_1 = "0"
Else
calculo_1 = -(parte / total) * Application.WorksheetFunction.Log(parte / total, 2)
Resultado_1 = (Resultado_1 + calculo_1)
End If
Next cpalabra
pGanancia = (total / (final - 1)) * Resultado_1
Acu_pGanancia = Acu_pGanancia + pGanancia
ganancia = Round(Entropia - Acu_pGanancia, 3)
Resultado_1 = 0
Next bpalabra
atributo_Ganancia = Trim(atributo_Ganancia) & " " & ganancia
Acu_pGanancia = "0"
sCadena_ganancia = atributo_Ganancia
Next n
Set listMatriz_A = CreateObject("System.Collections.ArrayList")
For Each nGanancia In Split(atributo_Ganancia, " ")
listMatriz_A.Add nGanancia
Next nGanancia
listMatriz_A.Sort
For Each nGanancia In listMatriz_A
sCadena_C = Trim(sCadena_C) & " " & nGanancia
Next nGanancia
matriz = Split([sCadena_C], " ")
For d = LBound(matriz) To UBound(matriz)
If d = UBound(matriz) Then Ganancia_max = matriz(d)
Next
For Each nGanancia In Split(sCadena_ganancia, " ")
Contador = Contador + 1
If nGanancia = Ganancia_max Then
columna = Contador
Exit For
End If
Next
'MOSTRAMOS INFO
For Each resultado In Split(atributo_Ganancia, " ")
s = s + 1
Sheets("RESULTADOS").Cells(1, 3) = "NODOS"
Sheets("RESULTADOS").Cells(1, 4) = "SELECCION ATRIBUTO NODO RAIZ"
Sheets("RESULTADOS").Cells(s + 1, 3) = .Cells(1, s + 1)
Sheets("RESULTADOS").Cells(s + 1, 4) = resultado
Next resultado

El resultado de esta parte del código es una matriz con las ganancias de cada nodo, la mayor determinará el nodo raíz, este es el resultado:

GENERANDO UN ALGORITMO ID3 EN VBA1

Por lo tanto, el nodo raíz es el “cielo“. A partir de esta variable deberemos finalizar el cálculo con el resto de atributos para finalizar nuestro árbol de decisión. Por lo tanto, utilizaremos la parte final del código:

'--------------------------------------------------
'SELECCION GANANCIA MAXIMA RESTO DE ATRIBUTOS
'--------------------------------------------------
'Variables utilizadas
'-------------------------------------------------------------------------
Dim c As Long, e As Long, f As Long, cCol As Long, h As Long
Dim j As Long, k As Long, p As Long, t As Long
Dim dpalabra As String, sCadena_D As String, unicos_C As String, epalabra As String
Dim fpalabra As String, sCadena_E As String, unicos_D As String, Control_gArgum As String
Dim Control_hArgum As String
Dim ncampo, fArgum, gArgum, hArgum
Dim fEntropia As Double, Entropia_B As Double, parte2 As Double, total2 As Double
Dim Acu_qGanancia As Double, qGanancia As Double, calGanancia_1 As Double, Acu_calGanancia_1 As Double
Dim ganancias_2 As Double
For c = 2 To final
dpalabra = dpalabra & "|" & .Cells(c, columna + 1)
Next c
sCadena_D = Trim(Mid(dpalabra, 2, Len(dpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_D, "|")
For d = 0 To UBound(matriz)
If Not oDic.Exists(matriz(d)) Then oDic.Add matriz(d), matriz(d)
Next d
unicos_C = Join(oDic.Keys, "|")
For Each ncampo In Split(unicos_C, "|")
For e = 2 To final
If CStr(.Cells(e, columna + 1)) = ncampo Then
epalabra = epalabra & "|" & .Cells(e, fin)
denominador = denominador + 1
End If
Next e
sCadena_D = Trim(Mid(epalabra, 2, Len(epalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_D, "|")
For f = 0 To UBound(matriz)
If Not oDic.Exists(matriz(f)) Then oDic.Add matriz(f), matriz(f)
Next f
unicos_C = Join(oDic.Keys, "|")
For Each fArgum In Split(unicos_C, "|")
fEntropia = -(UBound(Split(sCadena_D, fArgum)) / (denominador)) * Application.WorksheetFunction.Log(UBound(Split(sCadena_D, fArgum)) / (denominador), 2)
Entropia_B = Entropia_B + fEntropia
Next fArgum
For cCol = 2 To fin - 1
If cCol <> columna + 1 Then
For g = 2 To final
fpalabra = fpalabra & "|" & .Cells(g, cCol)
Next g
sCadena_E = Trim(Mid(fpalabra, 2, Len(fpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_E, "|")
For h = 0 To UBound(matriz)
If Not oDic.Exists(matriz(h)) Then oDic.Add matriz(h), matriz(h)
Next h
unicos_D = Join(oDic.Keys, "|")
For Each gArgum In Split(unicos_D, "|")
Control_gArgum = gArgum
For Each hArgum In Split(unicos_A, "|")
Control_hArgum = hArgum
parte2 = "0"
total2 = "0"
For j = 2 To final
If CStr(.Cells(j, cCol)) = gArgum And CStr(.Cells(j, fin)) = hArgum And CStr(.Cells(j, columna + 1)) = ncampo Then
parte2 = parte2 + 1
End If
Next j
For k = 2 To final
If CStr(.Cells(k, cCol)) = gArgum And CStr(.Cells(k, columna + 1)) = ncampo Then
total2 = total2 + 1
End If
Next k
If parte2 = "0" Or total2 = "0" Then
Acu_qGanancia = "0"
Else
qGanancia = -(parte2 / total2) * Application.WorksheetFunction.Log(parte2 / total2, 2)
Acu_qGanancia = (Acu_qGanancia + qGanancia)
End If
For n = 2 To final
If CStr(.Cells(n, cCol)) = gArgum And CStr(.Cells(n, fin)) = hArgum And CStr(.Cells(n, columna + 1)) = ncampo Then
numerador = numerador + 1
End If
Next n
Next hArgum
calGanancia_1 = (numerador / denominador) * Acu_qGanancia
Acu_calGanancia_1 = Acu_calGanancia_1 + calGanancia_1
ganancias_2 = Round(Entropia_B - Acu_calGanancia_1, 3)
Acu_qGanancia = 0
numerador = 0
Next gArgum
'MOSTRAR INFO
Sheets("RESULTADOS").Cells(1, 6) = "NODO RAIZ"
Sheets("RESULTADOS").Cells(t + 2, 6) = .Cells(1, columna + 1)
Sheets("RESULTADOS").Cells(1, 7) = "VARIABLES NODO RAIZ"
Sheets("RESULTADOS").Cells(t + 2, 7) = ncampo
Sheets("RESULTADOS").Cells(1, 8) = "ATRIBUTOS"
Sheets("RESULTADOS").Cells(t + 2, 8) = .Cells(1, cCol)
Sheets("RESULTADOS").Cells(1, 9) = "SELECCION DE GANANCIA MÁXIMA ATRIBUTOS"
Sheets("RESULTADOS").Cells(t + 2, 9) = ganancias_2
t = t + 1
fpalabra = vbNullString
Acu_calGanancia_1 = "0"
End If
Next cCol
Entropia_B = "0"
denominador = "0"
epalabra = vbNullString
Next ncampo
Sheets("RESULTADOS").Select
Set oDic = Nothing
Set listMatriz_A = Nothing
End With
End Sub

El resultado es el siguiente:

GENERANDO UN ALGORITMO ID3 EN VBA2

Una vez que tenemos los resultado, debemos de elegir aquellos atributos de cada uno de los nodos que dependen del nodo raíz: Soleado, Nublado y Lluvia.

La interpretación que podemos obtener después de haber generado el algoritmo es que el estado de cielo es el criterio determinante para realizar nuestra toma de decisiones, y en sus atributos, cuando el cielo está soleado y la humedad es alta no debemos jugar al tenis, tampoco cuando el cielo se encuentra lluvioso y el viento es fuerte, deberíamos ir a jugar. También deberíamos tener en cuenta si el cielo está soleado y la temperatura es alta, que no sería aconsejable ir a jugar al tenis.

Sin duda, con esta información podremos confeccionar un sencillo código condicional que nos va a permitir tomar decisiones futuras.

En un árbol de decisión, esta sería la secuencia:

GENERANDO UN ALGORITMO ID3 EN VBA3

Cuanto mayor número de ejemplos tengamos, mayor será la exactitud de las predicciones. Por ello, es aconsejable contar con una base de datos con información abundante antes de generar este tipo de algoritmos.

Soy consciente de que el código es complejo y largo, pero para poder hacerlo en un proceso continuo, es necesario contar con gran cantidad de variables, dado que tenemos que ir almacenando información que iremos utilizando a lo largo de la ejecución del código, de ahí el elevado número de variables utilizadas.

Por otra parte, aunque he extraído en cada bloque la información que a mi me parece relevante, se podrían extraer nuevas informaciones incluyendo pequeños procesos para crear cadenas de texto con los datos que se van generando, una buena forma de apreciar la información que va calculando y generando es ejecutar la macro pulsando la tecla “F8” desde el módulo de VBA.

He dejado la opción explícita en el código, dado que me ha ayudado a que no se me quedase ninguna variable sin declarar y hacer así el algoritmo más eficiente a la hora de consumir recursos.

Es muy importante que tengáis en cuenta que la salida de estos algoritmos debe ser la respuesta a preguntas dicotómicas, tipo: Verdadero – Falso, Si – No, etc.

En el archivo os encontraréis con tres pestañas:

En la primera (“DATOS”) estarán la información con la que calcularemos el algoritmo. IMPORTANTE: la primera columna siempre ha de hacer referencia al número de casos y la última a la respuesta, que como he dicho ha de ser dicotómica. Las columnas intermedias deben contener el resto de la información.

En la segunda pestaña (“RESULTADOS”), simplemente debemos pulsar el botón de comando que ejecutará el código y generará la información.

En la tercera pestaña (“EJEMPLOS”), os dejo varios casos para realizar pruebas.

Y esto ha sido todo, espero que os resulte de utilidad e interés. Puede ser una buena base para adaptarla a vuestros proyectos o cálculos.

Descarga el archivo de ejemplo pulsando en: GENERANDO UN ALGORITMO ID3 EN VBA

¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!

Anuncios

CREAR ÁRBOL DE DECISIÓN CON SMARTART Y VBA

Hace unos días, un lector me comentaba que el post que había realizado sobre crear organigramas en SmartArt, también se podía adaptar para realizar un árbol de decisión. Y es cierto, de hecho las estructuras jerárquicas que aparecen en SmartArt sí que sugieren su idoneidad para crear árboles de decisión.

Por lo que hoy realizaré un pequeño ejercicio de ejemplo para comprobar cómo se adapta a un caso práctico. Recomiendo complementar la lectura de esta entrada con estos dos post:

Investigando por internet he dado con una página muy interesante sobre árboles de decisión, cuyo autor es Federico Garriga Garzón y que se titula Problemas Resueltos de Teoría de Decisión

De todos los ejercicio expuestos, he elegido el que más me ha gustado, pero podéis adaptar el que queráis. Es el ejercicio 19 y su enunciado dice así:

Una empresa está considerando la posibilidad de contratar un experto en ingeniería industrial para la planificación de su estrategia de operaciones. Una adecuada planificación supondría a la empresa unos beneficios de 1.000.000 de euros, mientras que si la planificación no fuera correctamente elaborada, la empresa estima unas pérdidas de 400.000 euros. El director industrial estima que la probabilidad de que el experto realice una adecuada planificación es del 75%. Antes de contratar al experto, la empresa tiene la opción de realizar unas pruebas para determinar la idoneidad del candidato, dichas pruebas tienen una fiabilidad del 80% a la hora de determinar el éxito potencial del candidato en la realización de la planificación de las operaciones de la empresa. Determine la decisión óptima para la empresa, así como el coste que puede asumir la empresa por realizar la prueba de idoneidad.

Pues bien, antes de comenzar y como se indica en la solución, lo primero que debemos hacer es confeccionar el árbol de decisión, solo con las decisiones, sin indicar cálculos. Tomando este ejemplo, los datos que debemos escribir para generar la estructura en gráfico serían estos:

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA2

Y ejecutando la macro (que más adelante os mostraré) generamos esta estructura:

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA1

Ahora, siguiendo los pasos del ejercicio, debemos realizar los cálculos necesarios que nos ayuden a calcular coste y el criterio para tomar una decisión óptima.

Los cálculos los realizaré en otra hoja (“CÁLCULOS”), para más información y detalle, os remito al ejercicio para consultar fórmulas, conceptos y teorías aplicadas. Estos serían los cálculos (primero mostrando las fórmulas y luego con los resultados):

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA3

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA4

Una vez que tenemos todos los datos calculados, solo tenemos que trasladarlos a la hoja (“DATOS”) e ir añadiendo información en las columnas de la derecha, así:

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA6

En la columna “D” vamos a colocar los cálculos que se refieren a las probabilidades condicionadas, las probabilidades a priori de cada acontecimiento (si es o no idóneo el candidato) y la aplicación del teorema de Bayes en función de contratar al candidato si es o no idóneo y la planificación es o no idónea), el dato irá en rojo.

En la columna “E” indicamos que si se trata de una planificación correcta, el beneficio esperado es de 1.000.000 euros y si es incorrecta las pérdidas serían de  (400.000) euros.

Finalmente en la columna “F” la calculamos directamente en la hoja (“DATOS”) resolviendo de derecha a izquierda (siguiendo el gráfico) y aplicando criterio de esperanza matemática calculando el beneficio esperado de cada decisión. Una vez realizado el cálculo para los tres nudos a la derecha, debemos colocar el resultado (beneficio) mayor en el siguiente nudo. De esta forma determinar mediante criterio de esperanza matemática entre las dos decisiones (Si es o no idóneo el candidato).

Finalmente, y como se comenta en la solución del ejercicio, dado que la última etapa es determinista, se debe elegir la alternativa cuyo beneficio sea mayor. Colocamos los resultados en azul y según cada línea de decisión.

La columna “C” hace referencia a los niveles de decisión, en este caso tenemos 4 niveles con sus nodos correspondientes.

Ahora ejecutamos esta macro para generar el árbol de decisión:

Sub ARBOL_DECISION()
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim i, j, Fin As Double
With Sheets("ARBOL")
.Select
'Borramos cualquier forma que se encuentre en la hoja ARBOL
For Each Shape In .Shapes
Shape.Delete
Next
'Insertamos gráfico SmartArt, recomendable utilizar el de nombre y puesto
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart") 'Diseño de la forma Smartart
Set Inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = Inserta.SmartArt.AllNodes
'Damos formato los colores y estilos rápidos
With Sheets("ARBOL")
For Each Shape In .Shapes
Shape.SmartArt.Color = Application.SmartArtColors("urn:microsoft.com/office/officeart/2005/8/colors/accent0_1") ' Colores disponibles
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles("urn:microsoft.com/office/officeart/2005/8/quickstyle/3d5") 'Estilos rápidos
Next
End With
'colocamos la estructura a partir de la fila 3 y columna 1
.Shapes(1).Left = .Cells(3, 1).Left
.Shapes(1).Top = .Cells(3, 1).Top
Fin = Application.CountA(Sheets("DATOS").Range("A:A"))
'Creamos y eliminamos nodos según jerarquía y cantidad de nodos indicados en la DATOS
Do While oNodos.Count < Fin
oNodos.Add.Promote
Loop
For i = 1 To Fin
Do While oNodos(i).Level < Sheets("DATOS").Range("C" & i).Value
oNodos(i).Demote
Loop
With oNodos(i)
' Añadimos los datos de las columnas
v0 = Sheets("DATOS").Range("B" & i)
v1 = Sheets("DATOS").Range("D" & i)
v2 = Sheets("DATOS").Range("E" & i)
v3 = Sheets("DATOS").Range("F" & i)
'Contamos las palabras de cada columna
cv0 = UBound(Split(v0)) + 1
cV1 = UBound(Split(v1)) + 1
cv2 = UBound(Split(v2)) + 1
cv3 = UBound(Split(v3)) + 1
'Escribimos en cada nodo el contenido de las columnas
.TextFrame2.TextRange.Text = v0 & " " & v1 & " " & v2 & " " & v3
'Damos color (rojo y azul) a los valores de la misma forma que en el ejecicio de ejemplo
.TextFrame2.TextRange.Words(cv0 + 1, cV1).Font.Fill.ForeColor.RGB = vbRed
.TextFrame2.TextRange.Words(cv0 + cV1 + cv2 + 1, cv3).Font.Fill.ForeColor.RGB = vbBlue
End With
Next i
End With
'Formateamos el diseño del organigrama, lo presentamos con jerarquía horizontal "hierachy2"
With Sheets("ARBOL")
For Each Shape In .Shapes
Shape.SmartArt.Layout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/hierarchy2")
Next
End With
'Aumentamos zoom para ver correctamente el gráfico
ActiveWindow.Zoom = 180
'Liberamos variables
Set Diseño = Nothing
Set Inserta = Nothing
Set oNodos = Nothing
End Sub

He introducido algunas líneas de código nuevas para visualizar mejor el gráfico, (colocación y zoom) y también he implementado un pequeño sistema para colorear los ítems calculados y que forman parte del esquema.

Y el resultado es el siguiente:

CREAR ARBOL DE DECISIÓN CON SMARTART Y VBA5.jpg

Como podéis observar, el beneficio esperado es de 650.140 euros, fruto de la elección de mayor beneficio, entre “Hacer las pruebas: 650.140 euros” o “Contratar a un experto: 650.000 euros”. Es decir, el coste máximo que puede llegar a asumir la empresa para realizar las pruebas de idoneidad es de 140 euros.

Sin profundizar en los cálculos, el sentido del post es el de demostrar la posibilidad de implementar mediante SmartArt un árbol de decisión.

Por cierto, este post es el último del mes de Agosto, en breve me voy de vacaciones y estaré unos días desconectado 🙂 Nos vemos en Septiembre!!

Descarga el archivo de ejemplo pulsando en: CREAR ÁRBOL DE DECISIÓN CON SMARTART Y VBA