Juego del Caos cambiando el dado al orden del Genoma

Descargar como Notebook

En la publicación del Juego del Caos del 24 de abril del 2018 había mencionado el procedimiento dado por Michael Bransley para la generación de Fractales que también denominó Ping Pong Fractal, el procedimiento consistía en:

Se parte de tres puntos en una hoja A, B y C (que llamaremos vértices) no colineales, sobre la misma recta,  y otro punto P (que llamaremos punto de partida), se toma un dado y se lanza si el resultado es 1 o 2 nos dirigimos desde P hasta A pero nos quedamos a mitad de camino, si es 3 o 4 lo mismo pero dirigiéndonos a B y si es 5 o 6 dirigiéndonos a C, marcamos el punto sobre la hoja y volvemos a repetir el procedimiento desde el punto que nos habíamos quedado.

Al realizar este proceso se encuentra el triángulo de Sierpinski. Lo que vamos a ver ahora es que al aumentar el número de puntos (vértices) se encuentra un comportamiento fractal excepto para cuatro vértices.

Triángulo

puntos = 3;
vertices = 
  Table[0.5 {Cos[2 \[Pi] n/puntos] + 1, 
     Sin[2 \[Pi] n/puntos] + 1}, {n, 0, puntos - 1, 1}];
inicio = {0, 0};
ran := RandomChoice[Table[1./puntos, {n, puntos}] -> Range[puntos], 
   1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Cuadrado

puntos = 4;
vertices = 
  Table[0.5 {Cos[2 \[Pi] n/puntos] + 1, 
     Sin[2 \[Pi] n/puntos] + 1}, {n, 0, puntos - 1, 1}];
inicio = {0, 0};
ran := RandomChoice[Table[1./puntos, {n, puntos}] -> Range[puntos], 
   1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2.
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Y así sucesivamente obtenemos:

Pentágono

Hexágono

Heptágono

Octágono

Cambiando el Dado

El dado para las anteriores presentaciones lo hemos simulado con el comando RandomChoice que nos permite elegir el número de posibilidades (caras del dado) y la probabilidad de cada uno, en todos hemos tomado un dado homogéneo (igual probabilidad para todos los resultados).

Vamos a centrar nuestro trabajo en el cuadrado, que fue la única estructura que no formó un fractal.

Aquí viene la gran curiosidad, Mathematica tiene incorporada en su base de datos  los resultados del Genoma Humano en el comando GenomaData, donde podemos encontrar de casi 40000 genes su secuencia de ADN:

GenomeData[]

Para cada gen su secuencia corresponde a un listado de A: adenina, T: timina, C: citosina y G: guanina. Esta secuencia no es aleatoria pero para el no experto así lo parece, pues para mí lo es y la tomaré como los resultados del dado para seguir el Juego del Caos. To memos un gen cualquiera, tal parece que es indiferente de la elección, por ejemplo "7A5" y etiquetemos los vértices del cuadrado con A, T, C y G.

gen7A5 = Characters@GenomeData["7A5"]

lista = gen7A5;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2.]
Show[ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
  PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
  Axes -> False, PlotStyle -> PointSize[0.001]], 
 Graphics[{Text["A", {-0.1, -0.1}], Text["C", {1.1, -0.1}], 
   Text["T", {1.1, 1.1}], Text["G", {-0.1, 1.1}]}]]

La figura obtenida tiene un claro comportamiento fractal.

Cambiando el orden de las letras

Al cambiar el orden de los vértices se obtiene una figura diferente.

lista = gen7A5;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2.]
Show[ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
  PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
  Axes -> False, PlotStyle -> PointSize[0.001]], 
 Graphics[{Text["A", {-0.1, -0.1}], Text["C", {1.1, -0.1}], 
   Text["G", {1.1, 1.1}], Text["T", {-0.1, 1.1}]}]]

Manteniendo las mismas probabilidades

Considerando como probabilidades del dado en el comando RandomChoice la frecuencia de cada una de las letras en el Gen.

Tally[gen7A5]
{{"A", 25868}, {"T", 26721}, {"G", 15652}, {"C", 14495}}

Length[gen7A5]
82736

vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};
inicio = {1, 1};
ran := RandomChoice[{0.312657, 0.175196, 0.18918, 0.322967} -> {1, 2, 
     3, 4}, 1][[1]]
siguiente[punto_] := (vertices[[ran]] + punto)/2
ListPlot[NestList[siguiente, inicio, 100000], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Otro Gen

Ahora, por ejemplo al realizar el mismo proceso con el Gen "ZZZ3", se sigue manteniendo el mismo resultado.

lista = genZZZ3;
long = Length[lista];
rango[n_] := 
 Which[lista[[n]] == "A", 1, lista[[n]] == "C", 2, lista[[n]] == "G", 
  3, lista[[n]] == "T", 4]
dado = Table[rango[n], {n, Length[lista]}];
vertices = {{0, 0}, {1, 0}, {0, 1}, {1, 1}};

siguiente[punto_] := 
 Module[{num}, num = First[dado]; 
  dado = Rest[dado]; (vertices[[num]] + punto)/2]
ListPlot[NestList[siguiente, {0, 0}, Length[lista] - 1], 
 PlotRange -> {{-0.2, 1.2}, {-0.2, 1.2}}, AspectRatio -> 1, 
 Axes -> False, PlotStyle -> PointSize[0.001]]

Tal parece que este comportamiento fractal se encuentra con cualquier Gen y en cursos de Genética computacional este es un tema de estudio.


Para aprender más sobre Mathematica ingrese aquí sitio de aprendizaje de Wolfram o en mi website ustamathematica.wixsite.com/basicas