Paradoja del Cumpleaños

Seguramente haz escuchado de la “paradoja” del cumpleaños donde se desea determinar la probabilidad de que dos personas en un salón cumplan el mismo día. Para fines de este ejercicio considera que se tienen n personas, los años bisiestos no son contados ni se admiten las personas gemelas; además de que los posibles 365 cumpleaños tienen la misma probabilidad de ocurrir.

En resumen, se tienen las siguientes expresiones para determinar la probabilidad, bajo las condiciones anteriores, de que dos personas cumplan el mismo día y de que otra persona cumpla el mismo día que tú.

\[ \mathbb{P}=\left \{ \begin{matrix} \frac{365!}{365^n(365-n)!} & {si }1\le{n}\le {365}\\ 1 & \mbox{si }n\mbox{>365}\end{matrix}\right. ; \mathbb{P}=1- \left( \frac{364}{365}\right)^n \]

  1. Crea una función que, de acuerdo a una n válida, determine ambas probabilidades.

  2. Crea una gráfica donde se tengan la distribución de cada una de las probabilidades y determina si existe algún momento en el que hay la misma probabilidad, para una n, de que dos personas cumplan el mismo día y de que otra personas cumpla el mismo día que tú.

Solución:

  1. Crear la Función

Vamos a tomar nuestra muestra con \(n=50\), y estos cumpleaños los podemos ver como números entre 1 y 365

n <- 50
cumples <- sample(1:365, n, replace = TRUE)

Con la función duplicated veremos si hay algún cumpleaños replicado

any(duplicated(cumples))
## [1] TRUE

Se observa que en nuestra muestra por lo menos hay dos personas que cumplen años el mismo día.

Con la siguiente función vamos a estimar la probabilidad de que un cumpleaños se repita en nuestro salón, para ello se van a mostrar sets de 50 cumpleaños una y otra vez

C <- 10000
mismo <- function(n){
  cumples <- sample(1:365, n, replace=TRUE)
  any(duplicated(cumples))
}
resultado <- replicate(C, mismo(50))
mean(resultado)
## [1] 0.9686

Se observa que la probabilidad es alta, pero si escogemos un n como 365, la probabilidas será 1, bajo este comportamiento, ahora vamos a dar una función que nos permita calcular la probabilidad de que un cumpleaños sea compartido en el salón por dos personas

dos_prob <- function(n, C=10000){
  resultado <- replicate(C, mismo(n))
  mean(resultado)
}

Usando la función Sapply nos va a servir para poder efectuar operaciones de elementos por elementos de cualquier función

n <- seq(1,70)
prob <- sapply(n, dos_prob)

  1. Graficar las Probabilidades

Con lo anterior, se graficarán las probabilidades estimadas de que dos personas tengan el mismo cumpleaños en un salón de tamaño n

library(tidyverse)
## -- Attaching packages ----------------------------------------------------------- tidyverse 1.3.0 --
## v ggplot2 3.3.2     v purrr   0.3.4
## v tibble  3.0.3     v dplyr   1.0.2
## v tidyr   1.1.2     v stringr 1.4.0
## v readr   1.3.1     v forcats 0.5.0
## -- Conflicts -------------------------------------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
probabilidad <- sapply(n, dos_prob)
qplot(n, probabilidad)

Ahora la probabilidad de

\[ P=\frac{365!}{365^n(365-n)!} \]

La podemos ver de la siguiente manera:

\[ P=\frac{365}{365}*\frac{364}{365}*\frac{363}{365}*\cdot\ldots\cdot*\frac{365-n+1}{365} \]

Ahora realizamos una función que haga esto para cualquier número:

proba_exacta <- function(n){
  proba_unica <- seq(365,365-n+1)/365
  1 - prod( proba_unica)
}
ex_prob <- sapply(n, proba_exacta)
qplot(n, probabilidad) + geom_line(aes(n, ex_prob), col = "darkred")

Con esto terminamos el problema de la Paradoja del Cumpleaños

Relación Fibonacci-Eigen (vectores/valores)

Existen aplicaciones muy interesantes donde se utilizan los conocidos eigen vectores/valores de una matriz. Una de ellas es la relación que tienen estos con los conocidos números de Fibonacci. Recuerda que los números de Fibonacci quedan representados por la ecuación recursiva Fn=Fn−1+Fn−2 y de una manera muy sencilla se puede ver que

\[  \displaystyle{F_n \choose F_{n-1}}=\begin{pmatrix} 1 & 1 \\ 1 & 0 \end{pmatrix}\displaystyle{F_{n-1} \choose F_{n2}} \] 0. Crea una función para obtener el n-ésimo número de Fibonacci.

  1. Determina mediante el uso de R el eigen valor positivo correspondiente a dicha matriz (es decir, el famoso número áureo o número de oro).

  2. Crea una gráfica, para un n que desees, donde cada punto corresponda a (Fn−1,Fn−2) o (Fn,Fn−1). Dichos puntos deben ser de color de negro.

  3. En la misma gráfica coloca la recta sobre la que pasa el eigen vector correspondiente al eigen valor del punto 1.

  4. Elige algún punto de los graficados en el punto dos y multiplícalo por el eigen valor del punto 1 y grafícalo en color rojo ¿Qué sucedió?

  5. ¿Qué concluyes de todo esto?

Solución:

  1. Función Fibonacci

Primero se va a generar el n-ésimio número de la serie, por lo cual tenemos

fibo <- function(n) {

  if (n == 1) {
    
      return(0)
  }
  else if(n == 2) {
    
      return(1)
  }
  else if(n > 2) {
    
      return(fibo(n - 1) + fibo(n - 2))
  }
  
}

Ahora, verificamos que la función de el n-ésimo número de la serie

fibo(30)
## [1] 514229

Una vez que se comprobo que la función si da el n-ésimo número de la serie, se va a proponer otra función que nos calcule toda la serie de Fibonacci para algún n

serie_fibo <- function(m) {
    
    serie <- vector("numeric", length = m)
    
    for (i in 1:m) {
        
        serie[i] <- fibo(i)
    }

    return(serie)
}

Comprobamos que nuestra función sirve de manera correta

serie_fibo(30)
##  [1]      0      1      1      2      3      5      8     13     21     34
## [11]     55     89    144    233    377    610    987   1597   2584   4181
## [21]   6765  10946  17711  28657  46368  75025 121393 196418 317811 514229

  1. Número Aureo

    Vamos a calcular el número aureo, el cual va a salir de la siguiente Matriz

    \[ A= \begin{pmatrix} 1 & 1 \\ 1 & 0 \end{pmatrix} \]

    Entonces definamos la matríz

Elementos_matriz<- c(1,1,1,0)
Matriz_A <- matrix(Elementos_matriz, nrow = 2, ncol=2)
Matriz_A
##      [,1] [,2]
## [1,]    1    1
## [2,]    1    0

Ahora veamos que valores tiene nuestra Matriz

valor_matriz<-eigen(Matriz_A)
valor_matriz
## eigen() decomposition
## $values
## [1]  1.618034 -0.618034
## 
## $vectors
##            [,1]       [,2]
## [1,] -0.8506508  0.5257311
## [2,] -0.5257311 -0.8506508

Con ello obtenemos el eigen valor:

e_valor<-valor_matriz$values
e_valor
## [1]  1.618034 -0.618034

Ya por último calculando el número aureo tenemos:

n_aureo<-e_valor[1]
n_aureo
## [1] 1.618034

Por lo tanto si hemos llegado al número aureo:

\[ \phi=\frac{{1}+\sqrt{5}}{2}\approx1.618033989 \]

  1. Crear una gráfica para cualquier “n”

eje_x <- c()
eje_y <- c()

for(i in 1:10){
  eje_x[i-1]<-fibo(i)
  eje_y[i-1]<-fibo(i-1)
}

plot( eje_x, eje_y, type = "p", pch=16 , xlab = "F_n", ylab="F_n-1", main = "Serie de Fibonacci", col="black")

  1. Valor del Número Aureo (Graficamente)

Ahora sobre la gráfica anterio vamos a graficar el número aureo

plot( eje_x, eje_y, type = "p", pch=16 , xlab = "F_n",
      ylab="F_n-1", main = "Serie de Fibonacci", col="black")
abline(a=0,b=valor_matriz$vectors[2,1]/valor_matriz$vectors[1,1],
       col="green1")

  1. Un nuevo Punto * Número Aureo

Ahora nos indica el problema que vamos a graficar un nuevo punto en las graficas anteriores, el cual va a estar multiplicado por el número aureo.

Primero Definimos el nuevo punto por el cual vamos a multiplicar el número aureo y lo multiplicamos

p<-c(eje_x[8],eje_y[8])
nuevo<-p*n_aureo
nuevo
## [1] 33.97871 21.03444

Ahora realizamos la gráfica y vemos donde cae nuesto nuevo punto sobre la recta

plot( eje_x, eje_y, type = "p", pch=16 , xlab = "F_n",
      ylab="F_n-1", main = "Serie de Fibonacci", col="black")
abline(a=0,b=valor_matriz$vectors[2,1]/valor_matriz$vectors[1,1],
       col="green1")
lines(nuevo[1], nuevo[2], type="p", pch=16, col="red")

  1. Conclusiones

Es muy interesante el ver como de una simple matriz se puede desprender la razón aurea o número de oro, pero también es importante ver como se relaciona con la función de Fibonacci.

Iteraciones

En la mayoría de cursos que haz visto se ha tenido una gran cantidad de teoría sin ver algoritmos que te permitan comprobar dichas cosas. Vamos a arreglar un poco esto y crea alguna función o método iterativo para aproximar lo siguiente. En cada uno de los casos da un ejemplo para comprobar el funcionamiento de tu solución.

  1. Derivada. Para comprobar determina si la derivada de 2x2 en algún punto se aproxima con tu función.

  2. Integral. Puedes usar funciones positivas para comprobar tu función utilizando la interpretación de la integral.

  3. Perímetro de una circunferencia. Investiga un poco sobre la relación que existe entre el número de lados de un polígono regular y su perímetro, así como la longitud de los lados de un polígono inscrito en una circunferencia de radio r. Con esto tienes las bases para crear una función, que de acuerdo a un numero de lados n se vaya acercando al perímetro de una circunferencia. Al final puedes comprobar tus resultados con la formula ya conocida.

Solción

Para cada punto vamos a recordar un poco la definción (derivada, integral, etc.)

  1. Derivada

Recordemos que la derivada se define

La función f es derivable en a (interior al dom f) si existe

\[ \displaystyle\lim_{h \to 0}\frac{f(a+h)-f(a)}{h} \]

En ese caso, el límite se representa por f´(a) y se llama derivada de f en a.

Existen diversos métodos para aproximar una derivada, pero nosotros vamos a utilizar el de Newton Rhapson el cual nos dice:

Sea f una función derivable definida en un intervalo real [a,b] y sea f(r)=0, es decir, sea r una raiz real de f. Si xn es una aproximación a r, entonces la siguiente aproximación xn+1 esta dada por:

\[ \displaystyle{X_{n+1}}={X_{n}}-\frac{f(X_n)}{f´(X_n)},f´(X_n)\ne0 \] Nos pide aproximar

\[ f(x)=2x^2 \]

Además sabemos que dicha derivada es

\[ f´(x)=4x \]

Procedemos a realizar el Método de Newton Rhapson:

polinomio <- expression (2*x^2) 
derivada <- D(polinomio, "x")

x <- 0  
punto_inicial <- 1

while ( x != punto_inicial) {
  
  x <- punto_inicial 

reemp_polinimio <- eval(polinomio) 

reemp_derivada <- eval(derivada) 

#NEWTON RHAPSON

punto_inicial <- x - (reemp_polinimio/reemp_derivada) 

print(x)
}
## [1] 1
## [1] 0.5
## [1] 0.25
## [1] 0.125
## [1] 0.0625
## [1] 0.03125
## [1] 0.015625
## [1] 0.0078125
## [1] 0.00390625
## [1] 0.001953125
## [1] 0.0009765625
## [1] 0.0004882812
## [1] 0.0002441406
## [1] 0.0001220703
## [1] 6.103516e-05
## [1] 3.051758e-05
## [1] 1.525879e-05
## [1] 7.629395e-06
## [1] 3.814697e-06
## [1] 1.907349e-06
## [1] 9.536743e-07
## [1] 4.768372e-07
## [1] 2.384186e-07
## [1] 1.192093e-07
## [1] 5.960464e-08
## [1] 2.980232e-08
## [1] 1.490116e-08
## [1] 7.450581e-09
## [1] 3.72529e-09
## [1] 1.862645e-09
## [1] 9.313226e-10
## [1] 4.656613e-10
## [1] 2.328306e-10
## [1] 1.164153e-10
## [1] 5.820766e-11
## [1] 2.910383e-11
## [1] 1.455192e-11
## [1] 7.275958e-12
## [1] 3.637979e-12
## [1] 1.818989e-12
## [1] 9.094947e-13
## [1] 4.547474e-13
## [1] 2.273737e-13
## [1] 1.136868e-13
## [1] 5.684342e-14
## [1] 2.842171e-14
## [1] 1.421085e-14
## [1] 7.105427e-15
## [1] 3.552714e-15
## [1] 1.776357e-15
## [1] 8.881784e-16
## [1] 4.440892e-16
## [1] 2.220446e-16
## [1] 1.110223e-16
## [1] 5.551115e-17
## [1] 2.775558e-17
## [1] 1.387779e-17
## [1] 6.938894e-18
## [1] 3.469447e-18
## [1] 1.734723e-18
## [1] 8.673617e-19
## [1] 4.336809e-19
## [1] 2.168404e-19
## [1] 1.084202e-19
## [1] 5.421011e-20
## [1] 2.710505e-20
## [1] 1.355253e-20
## [1] 6.776264e-21
## [1] 3.388132e-21
## [1] 1.694066e-21
## [1] 8.470329e-22
## [1] 4.235165e-22
## [1] 2.117582e-22
## [1] 1.058791e-22
## [1] 5.293956e-23
## [1] 2.646978e-23
## [1] 1.323489e-23
## [1] 6.617445e-24
## [1] 3.308722e-24
## [1] 1.654361e-24
## [1] 8.271806e-25
## [1] 4.135903e-25
## [1] 2.067952e-25
## [1] 1.033976e-25
## [1] 5.169879e-26
## [1] 2.584939e-26
## [1] 1.29247e-26
## [1] 6.462349e-27
## [1] 3.231174e-27
## [1] 1.615587e-27
## [1] 8.077936e-28
## [1] 4.038968e-28
## [1] 2.019484e-28
## [1] 1.009742e-28
## [1] 5.04871e-29
## [1] 2.524355e-29
## [1] 1.262177e-29
## [1] 6.310887e-30
## [1] 3.155444e-30
## [1] 1.577722e-30
## [1] 7.888609e-31
## [1] 3.944305e-31
## [1] 1.972152e-31
## [1] 9.860761e-32
## [1] 4.930381e-32
## [1] 2.46519e-32
## [1] 1.232595e-32
## [1] 6.162976e-33
## [1] 3.081488e-33
## [1] 1.540744e-33
## [1] 7.70372e-34
## [1] 3.85186e-34
## [1] 1.92593e-34
## [1] 9.62965e-35
## [1] 4.814825e-35
## [1] 2.407412e-35
## [1] 1.203706e-35
## [1] 6.018531e-36
## [1] 3.009266e-36
## [1] 1.504633e-36
## [1] 7.523164e-37
## [1] 3.761582e-37
## [1] 1.880791e-37
## [1] 9.403955e-38
## [1] 4.701977e-38
## [1] 2.350989e-38
## [1] 1.175494e-38
## [1] 5.877472e-39
## [1] 2.938736e-39
## [1] 1.469368e-39
## [1] 7.34684e-40
## [1] 3.67342e-40
## [1] 1.83671e-40
## [1] 9.18355e-41
## [1] 4.591775e-41
## [1] 2.295887e-41
## [1] 1.147944e-41
## [1] 5.739719e-42
## [1] 2.869859e-42
## [1] 1.43493e-42
## [1] 7.174648e-43
## [1] 3.587324e-43
## [1] 1.793662e-43
## [1] 8.96831e-44
## [1] 4.484155e-44
## [1] 2.242078e-44
## [1] 1.121039e-44
## [1] 5.605194e-45
## [1] 2.802597e-45
## [1] 1.401298e-45
## [1] 7.006492e-46
## [1] 3.503246e-46
## [1] 1.751623e-46
## [1] 8.758115e-47
## [1] 4.379058e-47
## [1] 2.189529e-47
## [1] 1.094764e-47
## [1] 5.473822e-48
## [1] 2.736911e-48
## [1] 1.368456e-48
## [1] 6.842278e-49
## [1] 3.421139e-49
## [1] 1.710569e-49
## [1] 8.552847e-50
## [1] 4.276424e-50
## [1] 2.138212e-50
## [1] 1.069106e-50
## [1] 5.345529e-51
## [1] 2.672765e-51
## [1] 1.336382e-51
## [1] 6.681912e-52
## [1] 3.340956e-52
## [1] 1.670478e-52
## [1] 8.35239e-53
## [1] 4.176195e-53
## [1] 2.088097e-53
## [1] 1.044049e-53
## [1] 5.220244e-54
## [1] 2.610122e-54
## [1] 1.305061e-54
## [1] 6.525304e-55
## [1] 3.262652e-55
## [1] 1.631326e-55
## [1] 8.156631e-56
## [1] 4.078315e-56
## [1] 2.039158e-56
## [1] 1.019579e-56
## [1] 5.097894e-57
## [1] 2.548947e-57
## [1] 1.274474e-57
## [1] 6.372368e-58
## [1] 3.186184e-58
## [1] 1.593092e-58
## [1] 7.96546e-59
## [1] 3.98273e-59
## [1] 1.991365e-59
## [1] 9.956824e-60
## [1] 4.978412e-60
## [1] 2.489206e-60
## [1] 1.244603e-60
## [1] 6.223015e-61
## [1] 3.111508e-61
## [1] 1.555754e-61
## [1] 7.778769e-62
## [1] 3.889385e-62
## [1] 1.944692e-62
## [1] 9.723461e-63
## [1] 4.861731e-63
## [1] 2.430865e-63
## [1] 1.215433e-63
## [1] 6.077163e-64
## [1] 3.038582e-64
## [1] 1.519291e-64
## [1] 7.596454e-65
## [1] 3.798227e-65
## [1] 1.899114e-65
## [1] 9.495568e-66
## [1] 4.747784e-66
## [1] 2.373892e-66
## [1] 1.186946e-66
## [1] 5.93473e-67
## [1] 2.967365e-67
## [1] 1.483682e-67
## [1] 7.418412e-68
## [1] 3.709206e-68
## [1] 1.854603e-68
## [1] 9.273015e-69
## [1] 4.636508e-69
## [1] 2.318254e-69
## [1] 1.159127e-69
## [1] 5.795635e-70
## [1] 2.897817e-70
## [1] 1.448909e-70
## [1] 7.244543e-71
## [1] 3.622272e-71
## [1] 1.811136e-71
## [1] 9.055679e-72
## [1] 4.52784e-72
## [1] 2.26392e-72
## [1] 1.13196e-72
## [1] 5.659799e-73
## [1] 2.8299e-73
## [1] 1.41495e-73
## [1] 7.074749e-74
## [1] 3.537375e-74
## [1] 1.768687e-74
## [1] 8.843437e-75
## [1] 4.421718e-75
## [1] 2.210859e-75
## [1] 1.10543e-75
## [1] 5.527148e-76
## [1] 2.763574e-76
## [1] 1.381787e-76
## [1] 6.908935e-77
## [1] 3.454467e-77
## [1] 1.727234e-77
## [1] 8.636169e-78
## [1] 4.318084e-78
## [1] 2.159042e-78
## [1] 1.079521e-78
## [1] 5.397605e-79
## [1] 2.698803e-79
## [1] 1.349401e-79
## [1] 6.747007e-80
## [1] 3.373503e-80
## [1] 1.686752e-80
## [1] 8.433758e-81
## [1] 4.216879e-81
## [1] 2.10844e-81
## [1] 1.05422e-81
## [1] 5.271099e-82
## [1] 2.635549e-82
## [1] 1.317775e-82
## [1] 6.588874e-83
## [1] 3.294437e-83
## [1] 1.647218e-83
## [1] 8.236092e-84
## [1] 4.118046e-84
## [1] 2.059023e-84
## [1] 1.029512e-84
## [1] 5.147558e-85
## [1] 2.573779e-85
## [1] 1.286889e-85
## [1] 6.434447e-86
## [1] 3.217223e-86
## [1] 1.608612e-86
## [1] 8.043059e-87
## [1] 4.021529e-87
## [1] 2.010765e-87
## [1] 1.005382e-87
## [1] 5.026912e-88
## [1] 2.513456e-88
## [1] 1.256728e-88
## [1] 6.28364e-89
## [1] 3.14182e-89
## [1] 1.57091e-89
## [1] 7.85455e-90
## [1] 3.927275e-90
## [1] 1.963637e-90
## [1] 9.818187e-91
## [1] 4.909093e-91
## [1] 2.454547e-91
## [1] 1.227273e-91
## [1] 6.136367e-92
## [1] 3.068183e-92
## [1] 1.534092e-92
## [1] 7.670459e-93
## [1] 3.835229e-93
## [1] 1.917615e-93
## [1] 9.588073e-94
## [1] 4.794037e-94
## [1] 2.397018e-94
## [1] 1.198509e-94
## [1] 5.992546e-95
## [1] 2.996273e-95
## [1] 1.498136e-95
## [1] 7.490682e-96
## [1] 3.745341e-96
## [1] 1.872671e-96
## [1] 9.363353e-97
## [1] 4.681676e-97
## [1] 2.340838e-97
## [1] 1.170419e-97
## [1] 5.852095e-98
## [1] 2.926048e-98
## [1] 1.463024e-98
## [1] 7.315119e-99
## [1] 3.65756e-99
## [1] 1.82878e-99
## [1] 9.143899e-100
## [1] 4.57195e-100
## [1] 2.285975e-100
## [1] 1.142987e-100
## [1] 5.714937e-101
## [1] 2.857468e-101
## [1] 1.428734e-101
## [1] 7.143671e-102
## [1] 3.571836e-102
## [1] 1.785918e-102
## [1] 8.929589e-103
## [1] 4.464794e-103
## [1] 2.232397e-103
## [1] 1.116199e-103
## [1] 5.580993e-104
## [1] 2.790497e-104
## [1] 1.395248e-104
## [1] 6.976241e-105
## [1] 3.488121e-105
## [1] 1.74406e-105
## [1] 8.720302e-106
## [1] 4.360151e-106
## [1] 2.180075e-106
## [1] 1.090038e-106
## [1] 5.450189e-107
## [1] 2.725094e-107
## [1] 1.362547e-107
## [1] 6.812736e-108
## [1] 3.406368e-108
## [1] 1.703184e-108
## [1] 8.51592e-109
## [1] 4.25796e-109
## [1] 2.12898e-109
## [1] 1.06449e-109
## [1] 5.32245e-110
## [1] 2.661225e-110
## [1] 1.330612e-110
## [1] 6.653062e-111
## [1] 3.326531e-111
## [1] 1.663266e-111
## [1] 8.316328e-112
## [1] 4.158164e-112
## [1] 2.079082e-112
## [1] 1.039541e-112
## [1] 5.197705e-113
## [1] 2.598852e-113
## [1] 1.299426e-113
## [1] 6.497131e-114
## [1] 3.248566e-114
## [1] 1.624283e-114
## [1] 8.121414e-115
## [1] 4.060707e-115
## [1] 2.030353e-115
## [1] 1.015177e-115
## [1] 5.075884e-116
## [1] 2.537942e-116
## [1] 1.268971e-116
## [1] 6.344855e-117
## [1] 3.172427e-117
## [1] 1.586214e-117
## [1] 7.931068e-118
## [1] 3.965534e-118
## [1] 1.982767e-118
## [1] 9.913835e-119
## [1] 4.956918e-119
## [1] 2.478459e-119
## [1] 1.239229e-119
## [1] 6.196147e-120
## [1] 3.098074e-120
## [1] 1.549037e-120
## [1] 7.745184e-121
## [1] 3.872592e-121
## [1] 1.936296e-121
## [1] 9.68148e-122
## [1] 4.84074e-122
## [1] 2.42037e-122
## [1] 1.210185e-122
## [1] 6.050925e-123
## [1] 3.025462e-123
## [1] 1.512731e-123
## [1] 7.563656e-124
## [1] 3.781828e-124
## [1] 1.890914e-124
## [1] 9.45457e-125
## [1] 4.727285e-125
## [1] 2.363643e-125
## [1] 1.181821e-125
## [1] 5.909106e-126
## [1] 2.954553e-126
## [1] 1.477277e-126
## [1] 7.386383e-127
## [1] 3.693191e-127
## [1] 1.846596e-127
## [1] 9.232979e-128
## [1] 4.616489e-128
## [1] 2.308245e-128
## [1] 1.154122e-128
## [1] 5.770612e-129
## [1] 2.885306e-129
## [1] 1.442653e-129
## [1] 7.213265e-130
## [1] 3.606632e-130
## [1] 1.803316e-130
## [1] 9.016581e-131
## [1] 4.50829e-131
## [1] 2.254145e-131
## [1] 1.127073e-131
## [1] 5.635363e-132
## [1] 2.817681e-132
## [1] 1.408841e-132
## [1] 7.044204e-133
## [1] 3.522102e-133
## [1] 1.761051e-133
## [1] 8.805255e-134
## [1] 4.402627e-134
## [1] 2.201314e-134
## [1] 1.100657e-134
## [1] 5.503284e-135
## [1] 2.751642e-135
## [1] 1.375821e-135
## [1] 6.879105e-136
## [1] 3.439553e-136
## [1] 1.719776e-136
## [1] 8.598881e-137
## [1] 4.299441e-137
## [1] 2.14972e-137
## [1] 1.07486e-137
## [1] 5.374301e-138
## [1] 2.68715e-138
## [1] 1.343575e-138
## [1] 6.717876e-139
## [1] 3.358938e-139
## [1] 1.679469e-139
## [1] 8.397345e-140
## [1] 4.198673e-140
## [1] 2.099336e-140
## [1] 1.049668e-140
## [1] 5.248341e-141
## [1] 2.62417e-141
## [1] 1.312085e-141
## [1] 6.560426e-142
## [1] 3.280213e-142
## [1] 1.640106e-142
## [1] 8.200532e-143
## [1] 4.100266e-143
## [1] 2.050133e-143
## [1] 1.025067e-143
## [1] 5.125333e-144
## [1] 2.562666e-144
## [1] 1.281333e-144
## [1] 6.406666e-145
## [1] 3.203333e-145
## [1] 1.601666e-145
## [1] 8.008332e-146
## [1] 4.004166e-146
## [1] 2.002083e-146
## [1] 1.001042e-146
## [1] 5.005208e-147
## [1] 2.502604e-147
## [1] 1.251302e-147
## [1] 6.25651e-148
## [1] 3.128255e-148
## [1] 1.564127e-148
## [1] 7.820637e-149
## [1] 3.910319e-149
## [1] 1.955159e-149
## [1] 9.775796e-150
## [1] 4.887898e-150
## [1] 2.443949e-150
## [1] 1.221975e-150
## [1] 6.109873e-151
## [1] 3.054936e-151
## [1] 1.527468e-151
## [1] 7.637341e-152
## [1] 3.81867e-152
## [1] 1.909335e-152
## [1] 9.546676e-153
## [1] 4.773338e-153
## [1] 2.386669e-153
## [1] 1.193335e-153
## [1] 5.966673e-154
## [1] 2.983336e-154
## [1] 1.491668e-154
## [1] 7.458341e-155
## [1] 3.72917e-155
## [1] 1.864585e-155
## [1] 9.322926e-156
## [1] 4.661463e-156
## [1] 2.330731e-156
## [1] 1.165366e-156
## [1] 5.826829e-157
## [1] 2.913414e-157
## [1] 1.456707e-157
## [1] 7.283536e-158
## [1] 3.641768e-158
## [1] 1.820884e-158
## [1] 9.10442e-159
## [1] 4.55221e-159
## [1] 2.276105e-159
## [1] 1.138052e-159
## [1] 5.690262e-160
## [1] 2.845131e-160
## [1] 1.422566e-160
## [1] 7.112828e-161
## [1] 3.556414e-161
## [1] 1.778207e-161
## [1] 8.891035e-162
## [1] 4.445517e-162
## [1] 2.222759e-162
## [1] 1.111379e-162

Comprobando que todas las aproximaciones lleguen a cero tenemos

y<-2*(1.111379e-162)^2
y
## [1] 0

Puesto que el multiplicar nuestra función por la última iteración da cero, tenemos una buena aproximación, a continuación la veremos graficamente

expresiong <- function(x)(2*x^2)
curve(expresiong,-1,5,101,xlim=c(0,2), ylim = c(0,9))
abline(0,0,col="darkgreen")

  1. Integral

Recordemos nuestra definición de Integral definida de Cálculo

Dada f(x) una función continúa y positiva en el intervalo [a, b]. Se define la integral definida, en el intervalo [a, b], y la denotamos como

\[  \displaystyle\int_{a}^{b} f(x)\, dx \] Al igual que para derivadas tenemos métodos de aproximación, las integrales no se quedan atrás, y hay muchos métodos para aproximar integrales, tales como el Método del Trapecio, Newton Cotes, la Regla de Simpson, entre otros. Para nuestro gusto utilizaremos la Regla de Simpson o también conocida como Regla de Kepler, la cual nos dice:

Para poder entenderla un poco mejor solo se mencionará la Regla del Trapecio

En integración numérica, una forma de aproximar una integral definida en un intervalo [a,b] es mediante la Regla del Trapecio, es decir, que sobre cada subintervalo en el que se divide [a,b] se aproxima una función f por un polinomio de primer grado, para luego calcular la integral como suma de las áreas de los trapecios formados en esos subintervalos . El método utilizado para la regla de Simpson sigue la misma idea, pero aproximando los subintervalos de f mediante polinomios de segundo grado.

Esta dada por:

\[  \displaystyle\int_{a}^{b} f(x)\, dx\approx\frac{b-a}{6}[f(a)+4f[\frac{a+b}{2}]+f(b)] \] La integral que vamos a aproximar es

\[ \displaystyle\int_{1}^{10}cos(x)dx \]

regla_simpson = function(fun, a,b, n) {
if (n%%2 != 0) stop("En la regla de Simpson, n es par!")
h = (b-a)/n
i1 = seq(1, n-1, by = 2) # impares
i2 = seq(2, n-2, by = 2) # pares
h/3 * ( fun(a) + fun(b) + 4*sum( fun(a+i1*h)) + 2*sum(fun(a+i2*h)))
}

Verificando que sirve nuestro método de aproximación tenemos

regla_simpson(cos,1,10,100)
## [1] -1.385493

  1. Perimetro de Una Circunferencia

Para poder aproximar un poligono al diametro de una circunferencia, mejor conocido como un Poligono Circunstrito existen diversos métodos matemáticos para poder hacerlo, en partícular vamos a tomar el método de Arquímedes:

\[ X(t+1)=\frac{x_1}{\sqrt{(1-(\frac{X_t^2}{4}))}} \]

Si \(X_t\) , y \(P_t\) representan la longitud del lado del poligono se obtiene que

\[ P_t=3*2^t*X_t \forall t,P_t>\frac{\pi}{2} \]

Graficamente lo que queremos realizar es lo siguiente

plot(-1:1, -1:1, type='n', asp=1, xlab='CP1', ylab='CP2',col="orange")
symbols(0, 0, sqrt(.5), inches=F, add=T,col="blue")
rect(-0.5, -0.5, 0.5, 0.5, col="green")

Por lo que se va a crear una función en dónde vamos a obtener el límite superior de \(\pi\) para \(t=n\)

limite_sup<-function(n){
  x1<-1
  x2<-x1/sqrt(1-(x1^2/4))
  for(i in 1:n){
    L<-3*2^i
    p1<-L*x1
    p2<-L*x2
    cat(sprintf("t= %2i Lados: %10.0f Lim inf: %0.17f Lim sup dif %0.17f \n",i,L,p1/2, p2/2,p1-p2/2))
    x1<-sqrt(2-sqrt(4-x1^2))
    x2<-x1/sqrt(1-(x1^2/4))
  }    
}

Probando la función definida anteriormente con t = 4, calculamos el límite superior obtenido por Arquímedes

limite_sup(4)
## t=  1 Lados:          6 Lim inf: 3.00000000000000000 Lim sup dif 3.46410161513775527 
## t=  2 Lados:         12 Lim inf: 3.10582854123024976 Lim sup dif 3.21539030917347279 
## t=  3 Lados:         24 Lim inf: 3.13262861328123687 Lim sup dif 3.15965994209749912 
## t=  4 Lados:         48 Lim inf: 3.13935020304687207 Lim sup dif 3.14608621513144016

Y con esto podemos concluir que se tiene una buena aproximación de un Cuadrado que es un poligono Regular, a una Circunfernecia.

Procesamiento de Texto

La idea será sencilla aunque la implementación no lo se 🙈, por lo que podrías obtener más resultados de los que coloco aquí. De acuerdo a un archivo .txt que se te será proporcionado determinar lo siguiente:

  1. Cantidad de letras.

  2. Cantidad de vocales.

  3. Cantidad de espacios.

  4. Porcentaje que representa cada letra en el texto.

No importa si consideras a los caracteres especiales como letras o no, tampoco si haces distinción entre mayúsculas y minúsculas, ni tampoco las veces que tengas que cargar el archivo.

Solución:

Para esto se irán haciendo varias cosas, lo que primero se hace es cargar el el texto de Romeo y Julieta que se proporciono y vamos a limpiarlo

Primero vamos a cargar las librerías que se van a usar

library(tokenizers)
library(readr)
library(wordcloud)
## Loading required package: RColorBrewer
library(dplyr)
library(readr)
library(stringr)
library(tidyverse)
library(tm)
## Loading required package: NLP
## 
## Attaching package: 'NLP'
## The following object is masked from 'package:ggplot2':
## 
##     annotate
R_J<-"Romeo_and_Juliet.txt"

Ahora vamos a leer cada línea del libreto

libreto_0<-read_lines(R_J)

Después vamos a compactar todo un solo parrafo

libreto_1<-paste(libreto_0, collapse = "\n")

Una vez habiendo compactado todo el libreto en un solo parrafo, ahora vamos a quitar tanto los signos de puntuación, los saltos entre líneas y los espacios

libreto_2<-removePunctuation(libreto_1)
libreto_3<-str_replace_all(libreto_2, "\n", " ")
libreto_4<-str_replace_all(libreto_3, "[\\s]+", " ")

  1. Cantidad de Letras

letters<-tokenize_characters(libreto_4)
#Ahora veamos esto en una tabla
tab_letters<-table(letters[[1]])
#Por comodidad vamos a manejar lo anterior como un Data Frame
letters_dataf<-data.frame(letter=names(tab_letters),frecuencia = as.numeric(tab_letters))
letters_tot<-colSums(letters_dataf[-1], na.rm = TRUE)
letters_tot
## frecuencia 
##     105834

Por lo tanto la cantidad de letras que hay en este libreto es de \(105834\)

  1. Cantidad de Vocales

a<-letters_dataf[letters_dataf$letter=="a",]
e<-letters_dataf[letters_dataf$letter=="e",]
i<-letters_dataf[letters_dataf$letter=="i",]
o<-letters_dataf[letters_dataf$letter=="o",]
u<-letters_dataf[letters_dataf$letter=="u",]
#Se va a poner en forma de Mariz, para ver con que frecuencia se usan cada una de las vocales
vowels<-rbind(a,e,i,o,u)
vowels
##    letter frecuencia
## 1       a       8240
## 5       e      12818
## 9       i       6909
## 15      o       8805
## 21      u       3759

Ahora solo para determinar la cantidad de vocales se van a sumar

tot_vowels<-colSums(vowels[-1], na.rm = TRUE)
tot_vowels
## frecuencia 
##      40531

Por lo tanto se van a tener \(40531\) vocales distibuidas entre \([a,e,i,o,u]\)

  1. Cantidad de Espacios

Ahora deseamos saber la cantidad de espacios que hay en el texto, para ello vamos a utilizar el libreto_4; entonces vamos a contar primero la gran cantidad de caracteres que se tiene

caracteres<-count_characters(libreto_4)
caracteres
## [1] 131470

Ya con esto, solo nos queda restar la cantidad anterior, menos la cantidad de letras

spaces<-caracteres-letters_tot
spaces
## frecuencia 
##      25636

Por lo que la cantidad de espacios que hay en el texto es de \(25,636\)

  1. Porcentaje de Letras en el Texto

Para el porcentaje de letras utilizaremos lo siguiente

 tanto_porciento <- mutate(letters_dataf,porcentaje = 
                           (frecuencia /letters_tot)*100)
 tanto_porciento
##    letter frecuencia  porcentaje
## 1       a       8240  7.78577773
## 2       b       1715  1.62046223
## 3       c       2284  2.15809664
## 4       d       3934  3.71714194
## 5       e      12818 12.11141977
## 6       f       2030  1.91809815
## 7       g       1838  1.73668197
## 8       h       6787  6.41287299
## 9       i       6909  6.52814785
## 10      j        277  0.26173063
## 11      k        831  0.78519190
## 12      l       4975  4.70075779
## 13      m       3358  3.17289340
## 14      n       6468  6.11145757
## 15      o       8805  8.31963263
## 16      p       1551  1.46550258
## 17      q         65  0.06141694
## 18      r       6488  6.13035508
## 19      s       6585  6.22200805
## 20      t       9709  9.17380048
## 21      u       3759  3.55178865
## 22      v       1109  1.04786742
## 23      w       2519  2.38014249
## 24      x        125  0.11810949
## 25      y       2623  2.47840958
## 26      z         32  0.03023603

Con ello hemos logrado terminar la parte de procesamiento de Texto

Teorema Central de Límite

Es bien conocido el teorema que abordamos en este ejercicio y sólo para recordar, si X1,X2,… es una sucesión de variables aleatorias independientes e idénticamente distribuidas, con media μ y varianza finita σ2, la función de distribución de la variable aleatoria Z descrita por:

\[ \mathcal{Z}=\frac{{X_1+\cdot\ldots\cdot{+X_n}}-n\mu}{\sqrt{n\sigma^2}} \] tiende a la función de distribución normal estándar cuando n→∞. Entonces, tu objetivo será crear una función que, de acuerdo a una distribución (pueden ser tantas como conozcas) que sean adaptables a las condiciones del teorema, incluyendo como parámetros de la función la media y la varianza de dicha distribución y una n, se creen simulaciones de dicha distribución, al igual que la v.a. Z. Finalmente se tiene que dar las gráficas de probabilidad acumulada y de densidad correspondiente (puedes guardar todo en una lista). Al final, con un n grande dado en la función, se debería poder ver una “comprobación visual de dicho teorema”.

Como complemento del TLC vamos a definir las siguientes cosas:

\[ S_n=X_1+\cdot\ldots\cdot+X_n\longrightarrow Z_n=\frac{{S_n}-n\mu}{\sqrt{n\sigma^2}} \]

\[ \Rightarrow \displaystyle\lim_{n \to\infty}{P_r(\frac{{S_n}-n\mu}{\sqrt{n\sigma^2}}<z)}= \phi(z) \]

Solución:

Se define la variable aleatoria \(X\) como aquella función que lleva el resultado éxito al número 1 y el resultado fracaso al número 0, entonces se dice que \(X\) tiene distribución Bernoulli con parámetro \(p\in(0,1)\) y escribimos \(X\sim Ber(p)\). La función de probabilidad se puede escribir de la siguiente forma.

\[ f(x)=\left \{ \begin{matrix} 1-p & \mbox{si }x=0,\\ p & \mbox{ si x=1,}\\0 & eoc\end{matrix}\right. \]

Tambien su manera compactada:

\[ f(x)=\left \{ \begin{matrix} p^x(1-p)^{1-x} & {si }& X=0,1\\ 0 & \mbox{en otro caso}\end{matrix}\right. \]

Su función de distribución, tiene la siguiente forma

\[ f(x)=\left \{ \begin{matrix} 0 & \mbox{si }x<0,\\ 1-p & \mbox{si }& {0<x\le 1}\\1 & si & x\ge1\end{matrix}\right. \]

Su esperanza está dada por:

\[ E(x)=p \]

Su varianza está dada por:

\[ Var(x)=p(1-p) \]

Vamos a ilustrar el Teorema de Límite Central para el caso de una distribución \(Bernoulli(p)\)

#Primero damos el número de valores simulados de la v.a. suma s[1],...,s[k]
k<-1000
s<-rep(0,k)
#Ahora damos número los sumados x[1],...,x[n]
n<-5
x<-rep(0,n)
#Damos el parámetro(s)
p<-0.7
#Generamos sumandos de n al azár x[i] así como k sumas de s[i]
for(i in 1:k){
  x<-rbinom(n,1,p)
  s[i]<-sum(x)
}
#Cálculo de media, varianza y estandarización
media<-n*p
var<-n*p*(1-p)
s<-(s-media)/sqrt(var)
#Graficamos la función de Densidad
par(mfrow=c(1,2))
curve(dnorm(x),from=-3,to=3,ylim=c(0,0.6),ylab = "Función de Densidad",lwd=2,col="darkred")
hist(s,freq=FALSE,breaks=50,add=T,xlim=c(-3,3),ylim = c(0,5))
#Graficas de la Función de Distribución
distemp<-ecdf(s)
curve(distemp,from=-3,to=3,cex=0.1,ylab = "Función de Distribución")
curve(pnorm(x),from = -3,to=3,add=TRUE,col="navyblue")