2011-05-30 13 views
9

Primero un contexto no esencial para la diversión. Mi verdadera pregunta está muy abajo. Por favor, no toque el dial.FindRoot vs Solve, NSolve and Reduce

Estoy jugando con las nuevas funciones probabilísticas de Mathematica 8. El objetivo es hacer un análisis de potencia simple. El poder de un experimento es 1 menos la probabilidad de un error tipo II (es decir, anunciar 'no efecto', mientras que hay un efecto en la realidad).

Como ejemplo elegí un experimento para determinar si una moneda es justa. Supongamos que la probabilidad de tirar colas está dada por b (una moneda tiene b = 0,5), entonces la potencia para determinar que la moneda es sesgada para un experimento con n moneda voltea está dada por

1 - Probability[-in <= x - n/2 <= in, x \[Distributed] BinomialDistribution[n, b]] 

con en el tamaño de la desviación de la media esperada para una moneda que un dispuestos a llamar a sospechoso (en se elige de forma que para una moneda volcó n veces el número de colas será de unos 95% del tiempo dentro de la media +/- en; esto, por cierto, de termina el tamaño del error tipo I, la probabilidad de reclamar incorrectamente la existencia de un efecto).

Mathematica bien dibuja un gráfico de la potencia calculada:

n = 40; 
in = 6; 
Plot[1-Probability[-in<=x-n/2<=in,x \[Distributed] BinomialDistribution[n, b]], {b, 0, 1}, 
Epilog -> Line[{{0, 0.85}, {1, 0.85}}], Frame -> True, 
FrameLabel -> {"P(tail)", "Power", "", ""}, 
BaseStyle -> {FontFamily -> "Arial", FontSize -> 16, 
    FontWeight -> Bold}, ImageSize -> 500] 

enter image description here

I dibujó una línea a una potencia de 85%, lo que generalmente se considera que es una cantidad razonable de poder. Ahora, todo lo que quiero es los puntos donde la curva de potencia se cruza con esta línea. Esto me dice el sesgo mínimo que la moneda debe tener para que tenga una expectativa razonable de encontrarlo en un experimento con 40 volteos.

tanto, he intentado:

In[47]:= Solve[ Probability[-in <= x - n/2 <= in, 
    x \[Distributed] BinomialDistribution[n, b]] == 0.15 && 
    0 <= b <= 1, b] 

Out[47]= {{b -> 0.75}} 

Esta falla estrepitosamente, ya que para b = 0,75 la potencia es:

In[54]:= 1 - Probability[-in <= x - n/2 <= in, x \[Distributed] BinomialDistribution[n, 0.75]] 

Out[54]= 0.896768 

NSolve encuentra el mismo resultado. Reduce realiza lo siguiente:

In[55]:= res = Reduce[Probability[-in <= x - n/2 <= in, 
    x \[Distributed] BinomialDistribution[n, b]] == 0.15 && 
    0 <= b <= 1, b, Reals] 

Out[55]= b == 0.265122 || b == 0.73635 || b == 0.801548 || 
b == 0.825269 || b == 0.844398 || b == 0.894066 || b == 0.932018 || 
b == 0.957616 || b == 0.987099 

In[56]:= 1 -Probability[-in <= x - n/2 <= in, 
       x \[Distributed] BinomialDistribution[n, b]] /. {ToRules[res]} 

Out[56]= {0.85, 0.855032, 0.981807, 0.994014, 0.99799, 0.999965, 1., 1., 1.} 

Así, Reduce las arregla para encontrar las dos soluciones, sino que encuentra un buen número de otros que son totalmente equivocado.

FindRoot funciona mejor aquí:

In[57]:= FindRoot[{Probability[-in <= x - n/2 <= in, 
      x \[Distributed] BinomialDistribution[n, b]] - 0.15`}, {b, 0.2, 0, 0.5}] 
     FindRoot[{Probability[-in <= x - n/2 <= in, 
      x \[Distributed] BinomialDistribution[n, b]] - 0.15`}, {b, 0.8, 0.5, 1}] 

Out[57]= {b -> 0.265122} 

Out[58]= {b -> 0.734878} 

bien, larga introducción. Mi pregunta es: ¿por qué Solve, NSolve y Reduce fallan tan miserablemente (y silenciosamente) aquí? En mi humilde opinión, no puede ser precisión numérica ya que los valores de potencia encontrados para las diversas soluciones parecen ser correctos (se encuentran perfectamente en la curva de potencia) y se eliminan considerablemente de la solución real.

Para el Sr. mma8 privado.Asistente: La expresión de la potencia es uno pesado:

In[42]:= Probability[-in <= x - n/2 <= in, 
x \[Distributed] BinomialDistribution[n, b]] 

Out[42]= 23206929840 (1 - b)^26 b^14 + 40225345056 (1 - b)^25 b^15 + 
62852101650 (1 - b)^24 b^16 + 88732378800 (1 - b)^23 b^17 + 
113380261800 (1 - b)^22 b^18 + 131282408400 (1 - b)^21 b^19 + 
137846528820 (1 - b)^20 b^20 + 131282408400 (1 - b)^19 b^21 + 
113380261800 (1 - b)^18 b^22 + 88732378800 (1 - b)^17 b^23 + 
62852101650 (1 - b)^16 b^24 + 40225345056 (1 - b)^15 b^25 + 
23206929840 (1 - b)^14 b^26 

y no habría esperado Solve para manejar esto, pero tenía grandes esperanzas para NSolve y Reduce. Tenga en cuenta que para n = 30, en = 5 Solve, NSolve, Reduce y FindRoot todos buscan el mismo, las soluciones correctas (por supuesto, el orden polinomio es menor allí).

+0

me dejó un comentario en virtud de la respuesta de Daniel. Por lo que vale, Simplificar [desordenado && 0 <= b <= 1] es una ruta rápida hacia las soluciones. – telefunkenvf14

Respuesta

7

Diferentes métodos numéricos tendrán un costo diferente al manejar esto.

(1) Los que encuentran todas las raíces polinomiales tienen el trabajo más difícil, en el sentido de que pueden necesitar lidiar con polinomios desinflados. FindRoot está fuera de peligro allí.

(2) El polinomio es una perturbación de uno con una gran multiplicidad. Yo esperaría que los métodos numéricos tuvieran problemas.

(3) Las raíces están dentro de 1-2 órdenes de magnitud de tamaño. ASÍ QUE esto no está muy lejos de polinomios generalmente "malos" con raíces alrededor del círculo unitario.

(4) Lo más difícil es manejar Solve [num eqn e ineq]. Esto debe combinar métodos de resolución de desigualdad (es decir, descomposición cilíndrica) con la aritmética de máquina. Espera poca piedad.De acuerdo, esto es univariado, por lo que equivale a secuencias Sturm o la Regla de signos de Descartes. Todavía no se comportó numéricamente bien.

Aquí hay algunos experimentos que usan varias configuraciones de métodos.

n = 40; in = 6; 
p[b_] := Probability[-in <= x - n/2 <= in, 
    x \[Distributed] BinomialDistribution[n, b]] 

r1 = NRoots[p[b] == .15, b, Method -> "JenkinsTraub"]; 
r2 = NRoots[p[b] == .15, b, Method -> "Aberth"]; 
r3 = NRoots[p[b] == .15, b, Method -> "CompanionMatrix"]; 
r4 = NSolve[p[b] == .15, b]; 
r5 = Solve[p[b] == 0.15, b]; 
r6 = Solve[p[b] == 0.15 && Element[b, Reals], b]; 
r7 = N[Solve[p[b] == 15/100 && Element[b, Reals], b]]; 
r8 = N[Solve[p[b] == 15/100, b]]; 

Sort[Cases[b /. {ToRules[r1]}, _Real]] 
Sort[Cases[b /. {ToRules[r2]}, _Real]] 
Sort[Cases[b /. {ToRules[r3]}, _Real]] 
Sort[Cases[b /. r4, _Real]] 
Sort[Cases[b /. r5, _Real]] 
Sort[Cases[b /. r6, _Real]] 
Sort[Cases[b /. r7, _Real]] 
Sort[Cases[b /. r8, _Real]] 

{-0.128504, 0.265122, 0.728, 1.1807, 1.20794, 1.22063} 

{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \ 
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \ 
1.19648, 1.24659, 1.25157} 

{-0.128504, 0.265122, 0.733751, 0.834331, 0.834331, 0.879148, \ 
0.879148, 0.910323, 0.97317, 0.97317, 1.08099, 1.08099, 1.17529, \ 
1.17529, 1.23052, 1.23052} 

{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \ 
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \ 
1.19648, 1.24659, 1.25157} 

{-0.128504, 0.265122, 0.736383, 0.801116, 0.825711, 0.845658, \ 
0.889992, 0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, \ 
1.19648, 1.24659, 1.25157} 

{-0.128504, 0.75} 

{-0.128504, 0.265122, 0.734878, 1.1285} 

{-0.128504, 0.265122, 0.734878, 1.1285} 

Parece que está usando nSolve función nroots con el método de Aberth, y resolver podría ser simplemente llamando nSolve.

Los distintos conjuntos de soluciones parecen estar en todo el mapa. De hecho, muchos de los números que dicen ser reales (pero no lo son) podrían no ser tan malos. Compararé las magnitudes de un conjunto de este tipo con un conjunto formado a partir de la numerización de objetos raíz exactos (un proceso generalmente seguro).

mags4 = Sort[Abs[b /. r4]] 

Out[77]= {0.128504, 0.129867, 0.129867, 0.13413, 0.13413, 0.141881, \ 
0.141881, 0.154398, 0.154398, 0.174443, 0.174443, 0.209069, 0.209069, \ 
0.265122, 0.543986, 0.543986, 0.575831, 0.575831, 0.685011, 0.685011, \ 
0.736383, 0.801116, 0.825711, 0.845658, 0.889992, 0.902725, 0.902725, \ 
0.931526, 0.958879, 0.986398, 1.06506, 1.08208, 1.18361, 1.19648, \ 
1.24659, 1.25157, 1.44617, 1.44617, 4.25448, 4.25448} 

mags8 = Sort[Abs[b /. r8]] 

Out[78]= {0.128504, 0.129867, 0.129867, 0.13413, 0.13413, 0.141881, \ 
0.141881, 0.154398, 0.154398, 0.174443, 0.174443, 0.209069, 0.209069, \ 
0.265122, 0.543985, 0.543985, 0.575831, 0.575831, 0.685011, 0.685011, \ 
0.734878, 0.854255, 0.854255, 0.902725, 0.902725, 0.94963, 0.94963, \ 
1.01802, 1.01802, 1.06769, 1.06769, 1.10183, 1.10183, 1.12188, \ 
1.12188, 1.1285, 1.44617, 1.44617, 4.25448, 4.25448} 

Chop[mags4 - mags8, 10^(-6)] 

Out[82]= {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 
0.00150522, -0.0531384, -0.0285437, -0.0570674, -0.0127339, \ 
-0.0469044, -0.0469044, -0.0864986, -0.0591449, -0.0812974, \ 
-0.00263812, -0.0197501, 0.0817724, 0.0745959, 0.124706, 0.123065, 0, \ 
0, 0, 0} 

Daniel Lichtblau

+0

Gracias Daniel. Buen análisis. Me pregunto si las diversas rutinas no deberían verificar los resultados propios. La sustitución de las respuestas (b) en la ecuación original (p [b] == 0.15) mostraría que muchas respuestas son incorrectas. El caso 4, por ejemplo, arroja una p [b] de {0.15, 0.15, 0.144968, 0.0181931, 0.00598588, 0.00200976, \ 0.0000353934, 1.91439 * 10^-7, 4.91803 * 10^-10, 5.99531 * 10^-17, 2.67065 * 10^-6, 0.0000768558, 79.0574, 228.802, 14741.7, 27520.6}, donde es bastante fácil detectar las correctas. Tal revisión no parece demasiado difícil de implementar (en mi opinión ingenua y probablemente injustificada). –

+0

No estoy seguro de que la sustitución ayude. Lo que es probable es que el conjunto de raíces, muchas de las cuales están desactivadas, darán un polinomio con coeficientes bastante cercanos al original (advertencia: no lo he comprobado). Si es así, pulir uno o más vendrá a expensas de este polinomio general "cerrado". Pulir todos ellos, p. a través de las iteraciones de Newton podría tener alguno o todos los siguientes problemas. (1) Podría ser muy lento. (2) Puede que no esté tan bien acondicionado si el polinomio está cerca de uno con raíces múltiples. (3) Podría sufrir problemas de deflación. Confieso que solo estoy adivinando. –

+0

No estaba pensando en pulir y/o hacer otra iteración, sino en emitir advertencias o eliminar raíces incorrectas de la salida. –

1

Bueno, no es una respuesta adecuada, pero es una observación interesante. Solve[ ] tiene el mismo comportamiento que Reduce[ ] cuando se utiliza la opción magia (también conocido como):

n=40; 
in=6; 
Solve[Probability[-in<=x-n/2<=in, 
     x\[Distributed]BinomialDistribution[n,b]]==0.15 && 
     0<=b<=1,b, MaxExtraConditions->1] 

{{b -> 0.265122}, {b -> 0.736488}, {b -> 0.80151}, {b -> 0.825884}, 
{b -> 0.84573}, {b -> 0.890444}, {b -> 0.931972}, {b -> 0.960252}, 
{b -> 0.985554}} 
+0

@Sjoerd Buenas noches! –

8

Creo que el problema es sólo el instablitity numérico de encontrar las raíces de los polinomios de orden superior:

In[1]:= n=40; in=6; 
     p[b_]:= Probability[-in<=x-n/2<=in, 
          x\[Distributed]BinomialDistribution[n,b]] 

In[3]:= Solve[p[b]==0.15 && 0<=b<=1, b, MaxExtraConditions->0] 
     1-p[b]/.% 
Out[3]= {{b->0.75}} 
Out[4]= {0.896768} 

In[5]:= Solve[p[b]==0.15 && 0<=b<=1, b, MaxExtraConditions->1] 
     1-p[b]/.% 
Out[5]= {{b->0.265122},{b->0.736383},{b->0.801116},{b->0.825711},{b->0.845658},{b->0.889992},{b->0.931526},{b->0.958879},{b->0.986398}} 
Out[6]= {0.85,0.855143,0.981474,0.994151,0.998143,0.999946,1.,1.,1.} 

In[7]:= Solve[p[b]==3/20 && 0<=b<=1, b, MaxExtraConditions->0]//Short 
     1-p[b]/.%//N 
Out[7]//Short= {{b->Root[-1+<<39>>+108299005920 #1^40&,2]},{b->Root[<<1>>&,3]}} 
Out[8]= {0.85,0.85} 

In[9]:= Solve[p[b]==0.15`100 && 0<=b<=1, b, MaxExtraConditions->0]//N 
     1-p[b]/.% 
Out[9]= {{b->0.265122},{b->0.734878}} 
Out[10]= {0.85,0.85} 

(nb MaxExtraConditions->0 es en realidad la opción predeterminada, por lo que podría haber quedado fuera de la anterior.)

Ambos Solve y Reduce simplemente generan objetos Root y cuando se les da un coeficiente inexacto, se evalúan numéricamente automáticamente. Si nos fijamos en la salida (abreviado) Out[7] continuación verá el Root de la totalidad de orden polinomial 40a:

In[12]:= [email protected](20/3 p[b] - 1) 
Out[12]= -1 + 154712865600 b^14 - 3754365538560 b^15 + 43996471155000 b^16 - 
     331267547520000 b^17 + 1798966820560000 b^18 - 
     7498851167808000 b^19 + 24933680132961600 b^20 - 
     67846748661120000 b^21 + 153811663157880000 b^22 - 
     294248399084640000 b^23 + 479379683508726000 b^24 - 
     669388358063093760 b^25 + 804553314979680000 b^26 - 
     834351666126339200 b^27 + 747086226686186400 b^28 - 
     577064755104364800 b^29 + 383524395817442880 b^30 - 
     218363285636496000 b^31 + 105832631433929400 b^32 - 
     43287834659596800 b^33 + 14776188957129600 b^34 - 
     4150451102878080 b^35 + 942502182076000 b^36 - 
     168946449235200 b^37 + 22970789150400 b^38 - 
     2165980118400 b^39 + 108299005920 b^40 
In[13]:= Plot[%, {b, -1/10, 11/10}, WorkingPrecision -> 100] 

plot poly

De este gráfico se puede confirmar que los ceros están en (aprox) {{b -> 0.265122}, {b -> 0.734878}}. Pero, para obtener las partes planas en el lado derecho de la protuberancia requiere muchas cancelaciones numéricas. Esto es lo que parece que sin la explícita WorkingPrecision opción:

poly plot

Esta gráfica deja claro por qué Reduce (o Solve con MaxConditions->1, ver In[5] arriba) se encuentra (de izquierda a derecha) la primera solución adecuada y la segunda solución casi correctamente, seguida de una carga completa de crud.

+0

+1 Muy bonito .. –

+0

¿No debería el 30/3 in In [12] ser 30/2? Y, dado que la trama se realiza con el comando en In [3], ¿cómo puede el% en el comando referirse a Expandir en In [12]? Me pregunto, ya que no estoy usando esta configuración 'WorkingPrecision -> 100' en mi trama, ¿por qué mi trama sigue siendo fluida y no se comporta como la segunda? De hecho, no puedo reproducir tu segunda trama en absoluto. Al ingresar 'Plot [Expand @ (30/3 p [b] - 1) // Evaluar, {b, -1/10, 11/10}]' (sin 'WorkingPrecision') simplemente me da su primer gráfico. ¿Estás usando mma7? Estoy usando 8, y es posible que pueda manejar situaciones difíciles como esta mejor. –

+0

@Sjoerd Gracias por señalar los errores tipográficos, ¡corregidos ahora! En cuanto al segundo gráfico, es exactamente lo que dice ser [aquí hay una captura de pantalla con $ MachinePrecision] (http://i.imgur.com/7kj3I.png) y [WorkingPrecision-> 100] (http: // i.imgur.com/LfukJ.png). No estoy seguro de por qué tu máquina sería diferente. – Simon