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:

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
valor_i = Split(sCadena_ganancia, " ")
ReDim miArray(0 To UBound(valor_i))
For ii = 0 To UBound(valor_i)
miArray(ii) = CDbl(valor_i(ii))
Next ii
Do
Control = True
For ii = 0 To UBound(miArray) - 1
If miArray(ii) > miArray(ii + 1) Then
Control = False
BetaString = miArray(ii)
miArray(ii) = miArray(ii + 1)
miArray(ii + 1) = BetaString
End If
Next ii
Loop While Not (Control)
For Each nGanancia In miArray
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:

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:

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:

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:

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



¡¡Muchas gracias!!