Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Mathematics sorted by activeTolman–Oppenheimer–Volkoff numerical solutions with massless quark EoS
https://community.wolfram.com/groups/-/m/t/1910752
Hi everybody;
I am facing a problem in running a "Tolman–Oppenheimer–Volkoff numerical solutions with massless quark EoS". If anyone helps me to run the problem I shall thankful for that.Ayan Banerjee2020-03-27T11:49:38ZM2SLink v2.0, add-on that connects SAS and Mathematica is now available
https://community.wolfram.com/groups/-/m/t/1912510
I wanted to let the Mathematica user community know that version 2.0 of **M2SLink**, my Mathematica add-on that connects SAS and Mathematica, is now available both at the Wolfram online store and at my website: [harpercorditt.com][1].
M2SLink allows you to import your SAS data sets directly into your Wolfram notebook without having to use SAS transport files (or any other import file mechanism, for that matter). All your SAS user-defined formats are preserved so there is no loss of data integrity when importing your data. M2SLink also allows you to export data from your Wolfram notebook to a SAS data set. Last but not least, you can run any SAS program from within your Wolfram notebook and retrieve the SAS results immediately.
New in version 2.0: Based on v1.0 user feedback, the data set viewer has been completely rewritten as a native Mathematica function. This allows you to launch M2Slink's interactive scatter plot function and view your data alongside the scatter plot within your notebook. Here is an example:
![M2SLink interactive scatter plot and data set viewer][2]
I hope that if you have SAS data that you've always wanted to visualize/analyze within the Wolfram notebook environment, you will take a look at M2SLink. Please contact me if you are interested: richard.potter@harpercorditt.com
[1]: https://www.harpercorditt.com/
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=M2SLinkinteractivescatterplotanddatasetviewer.png&userId=1912218Richard Potter2020-03-28T16:45:58ZCalculate a numerical integration series of rectangles
https://community.wolfram.com/groups/-/m/t/1909277
I have this problem:
Let
QQ[t_] := If[EvenQ[Floor[t]], 0, 1]
which is a series of rectangle pulses.
Now we integrate QQ[t] from zero to some X.
qq[X_] := Module[{u}, NIntegrate[QQ[u], {u, 0, X}]]
Result is a straight line with slope equal to 1, and this is not true.
Where is my mistake?
VladimirVladimir Vojta2020-03-26T10:48:31Z3D version of the built-in VoronoiDiagram
https://community.wolfram.com/groups/-/m/t/1561288
**[Open in Cloud][1] | [See Original][2] | Download to Desktop via Attachments Below**
![enter image description here][3]
Here I will show how to create 3D version of VoronoiDiagram in Wolfram Language.
Note that there's currently no way to represent a collection of 3D Voronoi mesh cells in a `MeshRegion` or `BoundaryMeshRegion`.
Here's a routine that takes the dual of the `DelaunayMesh` and returns an `Association` where the keys are the points and the values are their respective Voronoi cells.
pad[?_][{min_, max_}] := {min, max} + ?(max-min){-1, 1}
VoronoiCells[pts_] /; MatrixQ[pts, NumericQ] && 2 <= Last[Dimensions[pts]] <= 3 :=
Block[{bds, dm, conn, adj, lc, pc, cpts, hpts, hns, hp, vcells},
bds = pad[.1] /@ MinMax /@ Transpose[pts];
dm = DelaunayMesh[pts];
conn = dm["ConnectivityMatrix"[0, 1]];
adj = conn . Transpose[conn];
lc = conn["MatrixColumns"];
pc = adj["MatrixColumns"];
cpts = MeshCoordinates[dm];
vcells = Table[
hpts = PropertyValue[{dm, {1, lc[[i]]}}, MeshCellCentroid];
hns = Transpose[Transpose[cpts[[DeleteCases[pc[[i]], i]]]] - cpts[[i]]];
hp = MapThread[HalfSpace, {hns, hpts}];
BoundaryDiscretizeGraphics[#, PlotRange -> bds]& /@ hp,
{i, MeshCellCount[dm, 0]}
];
AssociationThread[cpts, RegionIntersection @@@ vcells]
]
Example:
SeedRandom[10000];
pts = RandomReal[1, {10, 3}];
vc = VoronoiCells[pts]
[![enter image description here][4]][5]
Show[MapIndexed[
BoundaryMeshRegion[#, MeshCellStyle -> {1 -> {Black, Thick}, 2 -> {ColorData[112][First[#2]]}}] &,
Values[vc]
]]
[![enter image description here][6]][7]
Show[
MapIndexed[
BoundaryMeshRegion[#, MeshCellStyle -> {1 -> Black, 2 -> {Opacity[0.5], ColorData[112][First[#2]]}}] &,
Values[vc]
],
Graphics3D[{PointSize[Large], Point[pts]}],
Method -> {"RelieveDPZFighting" -> True}
]
[![enter image description here][8]][9]
Note that this works in 2D too:
SeedRandom[10000];
pts = RandomReal[1, {10, 2}];
vc = VoronoiCells[pts];
Show[MapIndexed[
BoundaryMeshRegion[#, MeshCellStyle -> {1 -> {Black, Thick}, 2 -> {ColorData[112][First[#2]]}}] &,
Values[vc]
], Epilog -> {PointSize[Large], Point[pts]}]
[![enter image description here][10]][11]
[1]: https://www.wolframcloud.com/objects/wolfram-community/3D-version-of-the-built-in-VoronoiDiagram-by-Chip-Hurst
[2]: https://mathematica.stackexchange.com/questions/18893/how-can-i-define-a-3d-version-of-the-built-in-voronoidiagram-voronoimesh-in-v10
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chip2.png&userId=20103
[4]: https://i.stack.imgur.com/jAV06.png
[5]: https://i.stack.imgur.com/jAV06.png
[6]: https://i.stack.imgur.com/Mb7jm.png
[7]: https://i.stack.imgur.com/Mb7jm.png
[8]: https://i.stack.imgur.com/fPEE1.png
[9]: https://i.stack.imgur.com/fPEE1.png
[10]: https://i.stack.imgur.com/TVptr.png
[11]: https://i.stack.imgur.com/TVptr.pngChip Hurst2018-11-28T19:03:50Z[GIF] Starry Night over Water
https://community.wolfram.com/groups/-/m/t/1599255
*NOTE: The complete notebook of this post is attached at the end.*
-------------------
![starry_night_over_water][1]
This cute little animation came to me while I was playing with [Dynamic](http://reference.wolfram.com/language/ref/Dynamic.html). I found it very lovely so would like to share it to the community.
So I wanted to know how many Dynamic primitives my 5 years old laptop can handle in one scene (i.e. [Graphics](http://reference.wolfram.com/language/ref/Graphics.html)). This is my first test scenario:
With[{num = 40, aspRatio = 3, splineOrder = 10},
With[{freqSet = Rescale @ Range @ num},
DynamicModule[
{
y = 0,
pts = Thread[
{
Rescale[Range @ num, {1, num}, aspRatio * {-1, 1}],
0
}
]
},
DynamicWrapper[
Graphics[
{
{
CapForm @ "Round",
Hue[0.58, 0.45, 0.55],
AbsoluteThickness @ 5,
BSplineCurve[
Dynamic @ pts, SplineDegree -> splineOrder, SplineKnots -> "Unclamped"
]
},
{
CapForm @ "Round", JoinForm @ "Round", GrayLevel @ 0.7, AbsoluteThickness @ 3,
Line @ Dynamic @ pts
},
{
Hue[0.1, 0.5, 0.95, 0.7],
AbsolutePointSize @ 20,
Point @ Dynamic @ pts
}
},
PlotRange -> {aspRatio * {-1, 1}, {-1.2, 1.2}},
PlotRangePadding -> Scaled[0.05],
ImageSize -> 600
],
y = Clock[{0, Infinity, 1 / 60}];
pts = MapIndexed[
Function[
{freq, idx},
{
Rescale[idx[[1]], {1, num}, aspRatio * {-1, 1}],
Sin[2 * Pi * freq * y]
}
],
freqSet
]
]
]
]
]
![helix][2]
Not too shabby! The motions are smooth, the points align perfectly.
Now this one I call *Everlasting Tide*:
With[
{
winding = 8, corners = 6, radius = 1, shift = 2, gravityPower = 10, freqPower = 1 / 3, symmetricDir = Pi / 2
},
With[{num = (corners * winding) + 1},
With[
{
? = Function[Rescale[#, {0, 1}, {0.2, 1}]][
Function[
x,
Plus[
1, -(TriangleWave[{0, 2}, (x - 1) * x] ^ (1 / freqPower))
]
][Rescale @ Range @ num]
]
},
DynamicModule[
{
t = 0,
pts = Function[
Function[
{?, d},
(radius + d) * {Cos[?], Sin @ ?}
]@@@#
][
Thread[
{
Rescale[
Range @ num,
{1, num},
{0, winding * 2 * Pi} + symmetricDir
],
0
}
]
]
},
DynamicWrapper[
Graphics[
{
{
Hue[0.1, 0.2, 0.9],
AbsoluteThickness @ 1,
Map[
Circle[{0, 0}, #]&,
Rescale[
Rescale[Range[100]] ^ gravityPower,
{0, 1},
{Max[0, radius + -shift], radius + shift}
]
]
},
{GrayLevel @ 0.85, Line @ Dynamic @ pts},
{
Hue[0, 0.55, 0.85, 0.3],
AbsolutePointSize @ 10,
Point @ Dynamic @ Most @ pts
},
{
GrayLevel[0.7, 0.4],
EdgeForm @ {Black, AbsoluteThickness @ 1},
FilledCurve[BSplineCurve[Dynamic @ Most @ pts, SplineClosed -> True]]
}
},
PlotRange -> ((radius + shift) * {{-1, 1}, {-1, 1}}),
PlotRangePadding -> Scaled[0.05],
Axes -> False, ImageSize -> 500
],
t = Clock[{0, Infinity, 1 / 60}];
pts = Function[
Function[
{?, d},
(radius + d) * {Cos[?], Sin @ ?}
]@@@#
][
MapIndexed[
Function[
{?, idx},
{
Rescale[
idx[[1]],
{1, num},
{0, winding * 2 * Pi} + symmetricDir
],
Times[
shift,
Subtract[
2 * ((Sin[? * t] + 1) / 2) ^ gravityPower,
1
]
]
}
],
?
]
]
]
]
]
]
]
![everlasting_tide][3]
But back to my most beloved animation at the beginning. I introduce to you: *Starry Night over Water*. A winter night is painted by the palette of the cosmos. Each star whirls in its own delight, unknowingly lighting the quiet water below in a blurry expansion of everchanging hues. I'm really thrilled how such a lovely piece of animation can be created with a little more than 2000 character in code, and the background optimization done by *Mathematica* to make it run so smoothly.
P.S. I have used explicit iteration here instead of [Clock](http://reference.wolfram.com/language/ref/Clock.html) to drive the animation, so that this small quiet world shall be immune from a certain overflow ;)
**Things to try:**
Playing with the parameters of the outmost [With](http://reference.wolfram.com/language/ref/With.html), say, changing `baseColorFunc` to `ColorData["SunsetColors"]`, or changing `aspRatio` to match your monitor then menu-bar > **Window** > **FullScreen**.
With[
{
(* time step of the animation: *) ?t = 0.05,
(* number of stars: *) n = 50,
(* maximal size of stars: *) radius = 1.5,
(* color theme: *) baseColorFunc = ColorData @ "StarryNightColors",
(* geometric properties of the water region: *)
waterBase = -2, waterWidth = 5,
(* geometric properties of the final drawing: *)
height = 20, imageHeight = 700, aspRatio = 1 / GoldenRatio
},
With[{width = (height + (-waterBase) + waterWidth) / aspRatio},
Apply[
Function[{?0, ?, expr},
DynamicModule[{? = ?0},
DynamicWrapper[
Deploy @ Activate @ expr,
? = Mod[? + ? * ?t, 2 * Pi]
]
]
]
][
Module[{cx, cy, ?x, ?y, color},
{
RandomReal[{0, Pi / 2}, n],
RandomReal[{0.3, 1}, n],
Inactive[Graphics][
{
(* background: *)
Module[
{
h = height + (-waterBase) + waterWidth + 10,
w = width + 5,
m = 10, ?h, cf = baseColorFunc /* (Darker[#, 0.5]&)
},
?h = h / m;
MapThread[
Function[
{y, c1, c2},
{
EdgeForm[],
Polygon[
{
{-5, y},
{w, y},
{w, y + ?h},
{-5, y + ?h}
},
VertexColors -> Map[cf, {c1, c1, c2, c2}]
]
}
],
{
Function[
Rescale[
#,
{1, m},
{(waterBase + -waterWidth) - 5, height + 5 + -?h}
]
][Range @ m],
Most[
Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]]
],
Rest[
Function[0.4 * (1 + -#) ^ 5][Rescale[Range[m + 1]]]
]
}
]
],
(* foreground: *)
MapThread[
Function[
{cpos, r, idx, shineShift},
{cx, cy} = cpos;
{?x, ?y} = cpos + -({width, height} / 2);
(* base color: *)
color = baseColorFunc[
1 + -Norm[{?x, ?y} / {width, height}, 1]
];
{
(* one star: *)
{
FaceForm @ {Append[(* transparency: *) 0.7][color]},
EdgeForm[],
Polygon[
Map[
Function[cpos + r * #],
{
{0, 1},
{Cos[Dynamic[?[[idx]]]], 0},
{0, -1},
{-Cos[Dynamic[?[[idx]]]], 0}
}
]
]
},
(* and its reflection: *)
{
RightComposition[
ColorConvert[#, "LAB"]&,
(* adjust luminance according to shineShift (i.e. y-coords): *)
ReplacePart[
1 -> RightComposition[
Function[Cos[2 * #]],
Function[((# + 1) / 2) ^ 0.5],
Function[
Rescale[
#,
{0, 1},
Plus[
(* mean luminance, lower the brighter: *)
Rescale[shineShift, {-1, 1}, {0.4, 0.7}],
(* luminance variation range, lower the more active: *)
{-1, 1} * Rescale[shineShift, {-1, 1}, {0.3, 0.03}]
]
]
]
][Dynamic[?[[idx]]]]
],
(* transparency: *)
Append[Function[Rescale[#, {-1, 1}, {0.2, 0.6}]][shineShift]]
][color],
(* abstract blur: *)
AbsoluteThickness[Function[Rescale[#, {-1, 1}, {10, 1}]][shineShift]],
Line[
Function[
{
{
Plus[
cx, -(Times[
r,
Times[
#3,
Times[
1 / 2,
1 + -(#2 * Cos[Dynamic[?[[idx]]]])
]
]
])
],
#
},
{
Plus[
cx,
Times[
r,
Times[
#3,
(1 / 2) * (1 + #2 * Sin[Dynamic[?[[idx]]]])
]
]
],
#
}
}
][
(* y-coords: *)
Plus[
waterBase,
waterWidth * ((Rescale[shineShift, {-1, 1}] ^ 0.5) - 1)
],
(* variance: *)
Rescale[shineShift, {-1, 1}, {1, 0.2}],
(* mean radius: *)
Rescale[shineShift, {-1, 1}, {2, 4}]
]
]
}
}
],
{
Join[
ScalingTransform[{3 / 4, 3 / 4}, {width, height} / 2][
RandomPoint[Rectangle[{0, 0}, {width, height}], Ceiling[n / 4]]
],
RandomPoint[
Rectangle[{0, 0}, {width, height}],
(n + -Ceiling[n / 4]) - 1
],
{{width, height} / 2}
],
radius * RandomReal[{1 / height, 1}, n],
Range @ n,
RandomReal[{-1, 1}, n]
}
]
},
PlotRange -> {{0, width}, {waterBase + -waterWidth, height}},
PlotRangePadding -> {{2, 2}, {1, 2}},
Background -> None,
ImageSize -> {Automatic, imageHeight}
]
}
]
]
]
]
![starry_night_over_water][4]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1243starry_night_over_water.gif&userId=93201
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=helix32.gif&userId=93201
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=everlasting_tide_64.gif&userId=93201
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=starry_night_over_water.gif&userId=93201Silvia Hao2019-01-26T04:26:46ZAn SEIR like model that fits the coronavirus infection data
https://community.wolfram.com/groups/-/m/t/1888335
SEIR models for data from China, Italy, US, and Finland; and for Spain, UK, France, Germany, and again for Finland in a response at the end of the discussions in the post. For an explanation of SEIR models see Robert Nachbar's post:
https://community.wolfram.com/groups/-/m/t/1896178
It is possible to model the data by assuming a low enough susceptibility. I explain in the discussion with Robert Nachbar below why the main effect of containment measures is to lower the effective number of susceptible individuals. As a CAVEAT, these models are models of the DETECTED number of cases, not the TRUE number of cases. However, they allow us to understand how the disease evolves in time. Also, the newer models are adjusted quite frequently, especially with respect to the number of susceptible individuals, as they continue to grow. They tend to stabilize about three weeks after control measures have been in place. After the I curve peaks, it is possible to begin to get an idea of how long the outbreak will last. Ahead you can find the equations.
s'(t) = -Beta * s(t) * i(t) / p,
e'(t) = Beta * s(t) * i(t) / p - Sigma * e(t),
i'(t) = Sigma * e(t - m) - Gamma * i(t - n),
r'(t) = Gamma * i(t - n)
beta is the rate of infection, sigma is the rate at which an exposed individual becomes infective,
gamma is the removal rate, m and n are shift parameters to line up the curves (different countries release patients at different times). The parameter values are in the titles of the pictures for each country.
Directly in this post we find pictures for the models of China, Italy, the U.S., and one model for Finland. In a response, towards the bottom of the post, you can find two alternative models for Finland. In a separate response, models for France, Germany, Spain, and the U.K.
I have removed the alternative model picture, which shows the effect of lowering sigma (flattens the curve).
March 29: Updated
March 24-27 AM EET: All models updated; PM EET: Europe models (some are at the bottom of discussion) models updated. I UPDATED and CORRECTED the NOTEBOOK.
March 23 AM EET: China and US pictures updated, as well as the reply to the post at the bottom with the five major European countries other than Italy, and Finland. Italy picture updated in the pm. The hopefully good news is that all major European countries saw a decline in the number of daily new cases yesterday. In the PM, the numbers for Italy have declined for two days in a row. If the trend continues, the I curve will peak in about 11 days. The model has changed slightly.
March 21-22 AM EET: China and US pictures updated. Large Europe countries other than Italy will be updated in the morning EET. They are found in the PDF document. In the PM the Italy model is updated. It looks like the daily new cases might have peaked yesterday. The new picture has a theoretical new daily cases peak marked as a blue dot, after which we can expect 13 days before the actual peak of the I curve. Then comes the tail, with the end of the outbreak 1 to four months (or possibly more) later. I am hoping that indeed new daily cases peaked yesterday but only time can tell. At the end of the discussion, in a reply, there is now a model for Finland.
March 20, PM EET: China, USA updated. I have updated the notebook with the China model. The Italy model has changed substantially and is now much tighter.
March 19, PM EET: China, USA, and Italy models updated. The Italy model parameters have changed again to fit the data up to this point as there is no indication of the growth of the I curve slowing down. When I first posted this, in one of the discussions, we made a forecast that the first day with no new infections (not imported) would be March 23. Apparently this has happened already yesterday, March 19.
March 18, 8:00 PM EET: China model picture updated. I corrected a mistake in the label of the picture (p=81 K). US model added. Italy model updated.
March 17: Updated. In about a week there should be enough data for other countries. The China model has now been stable for quite a while, the Italy model I still change a little bit now and then. It is worth recalling that what makes this model successful is the low number for the effective susceptibility, something that I explained with a thought experiment earlier. Containment efforts essentially remove people from the infection path, lowering the number of susceptible individuals. Please read the discussions.
March 16 - NB: I have updated the China picture and the Italy model has stabilized, and is updated and unchanged. If the containment measure in Italy as working as it is hoped for, the I curve should be peaking in about a week or so. The curve is somewhat more spread out than for China, so that the recovery to current China levels would take about 80 days rather than 40 which it has in China. The overall number of cases should be of about the same size as well, a bit larger. We only hope for the best.
March 15: updated. It is almost a safe bet to say that the situation in Italy will end up being worse than in China. It seems other western countries are headed in the same direction, unfortunately, due to various sorts of circumstances, in each country its own, including the country where I live, Finland. When I have enough data, I will move out the alternative model picture and put up the picture of a new country.
March 14: updated.
March 13: I have tried to match the tail of the I curve and the R curve in the China model, since the data is necessarily more reliable there. I will try to include models for other countries in the notebook as I am able to ... maybe in a week. I cannot post all the pictures here, I think I can post up to 5 pictures, but I will include the models in a notebook and update it periodically, albeit, not daily.
March 12: I have made an important change in the China model. I have removed the correction factor for counting method change to agree with the number of current reported active cases. What this means is that during the climb phase of the I curve, there was some under reporting of cases; and for a few days, there was also over reporting. The blue curve now agrees with the red data in this respect. We will probably never know what exactly happened, but I believe the model tells the story. We also get a very good fit for the recovery curve. The new parameters are in the title label. The timeline now starts on Jan 11. The effective susceptible population, which is what we know now, stands at 81 K. I have updated the equations picture and the situation in Italy as well.
March 9-11: updated
March 8: I managed to access the internet. The China model has new parameters to adjust for what will possibly be a somewhat lower final total number of cases. The Italy model has the same parameters as the original China model, but I expect this to evolve rapidly. The parameters are now indicated in the picture title.
March 7: I am on travel ... I will update this post in a week. Briefly, the model for italy remains to be the blue model but with p=25000. I apologize I cannot update the pictures, I only have good internet access through my mobile device
March 6: I update the picture for China and for Italy. There is also (in the same picture) a probably better alternative model for Italy.
March 5: made a correction in the notebook (rendering) and updated the picture. I have added a picture for the situation in Italy. The model is the same, except for p=15000 and for shorter horizontal shifts ... the illness does not seem as prolonged. How this will turn out to be in the end is anybody's guess right now. I estimated the size for p based on the size of the population of the cordoned area. I have removed an old picture. I will update the notebook with the Italy (and other models) later.
March 4: picture updated, minor corrections. March 2 forecasts are now superseded by a virtual end of the outbreak by March 23 with some possible further cases later on. I have attached a notebook as a file, but I could not figure out how to login to post it - I am new here.
March 3: I have managed to remove all time dependencies from the parameters and get the same good fit. I am updating the picture and publishing the equations (see the picture at the end of the post with the equations and parameter values) of what is a somewhat simplified SEIR model which I have used. From it one can calculate R0 in the usual way, and it is much higher than what I reported before. I do not what to make of it. The effective susceptible population is now 82000. I developed this yesterday and it was good to see that no modifications were needed to fit today's data. Unless there are further changes that need explaining, I will refrain from posting for a few days or a couple of weeks, except for updating the picture. Recall that what makes this possible is noting that the effect of containment and lockdown is to effectively remove a large sector of the population from susceptibility ... see my the first post and my earlier replies to questions asked in the discussion. When I have time, I will clean my notebook and post it will all the data (it is not that much).
Today I am also adding a figure that illustrates the effect of lowering sigma to .03 (sigma is the rate at which the exposed becomes infective). It flattens the curve with a delay ... I don't know what measures can bring this down, but that is what is needed.
March 2: I am adding a second updated graph for comparison with the original, and will update that graph on a weekly or biweekly basis. I will now leave the model untouched for a week. In the latest graph, the initial population is 88000, the removal rate is now .3, and the delay is to onset of infection is 10% longer and slightly different. The calculated R0 is now 8. The model now predicts close to 85000 cases by the end of March, and close to 87500 towards the end of April. I have added the E curve in Cyan.
Feb 29: It is the end of February and there is one minor final correction that makes the fit still better (after this I will let this rest for a while). The green dots which are to be matched against the R (resistant) curve is now the sum of recoveries and fatalities. There is a new picture. The susceptible population is now 90000 and all the rest is the same.
If the model has any predictive power, I would expect to see about 84700 registered cases by the end of March, and about 88700 by the end of April. I will return to this towards the end of March, or earlier if this needs to be modified further.
Also, running a similar model without data at the moment for my community, the metropolitan area of Helsinki, if we assume only city and country isolation, we can expect an outbreak that lasts about 9 months if the virus is a year round virus (that is, not a "winter" virus). Likewise, an unchecked outbreak for the whole world would last about 15 months as of now if the virus is year round. About half of the population would be infected at one point.
Feb 28: I am updating this again because I have managed to get a much improved model by accounting for a delay in the onset of recovery as well as a delay in the onset of infection; moreover, I use my parameters uniformly throughout the equations, (some weeks down the road, when the data is "complete" I will publish the final equations of the model; I am hoping that the model as it stands now will stand the test of time). The infection rate is now 2.9, the susceptible population is 95000, the rate at which an exposed person becomes infected is now .057, and the removal rate is .25. Calculating R0 in the usual way, we get around 9, which is believable. I leave yesterday's text below, but I am changing the picture.
Feb 27: I am updating and correcting this post: a simple SEIR model with some modifications (like a delay factor for the onset of recovery) fits the available data of the coronavirus infection in China. The infection rate is 2.7, the removal rate is .1, the rate at which an exposed person becomes infective is .055, and the total susceptible population is 180 000. The model suggests that containment method effectively removed most of the population away from the infection path. This also suggests that the spread of this pathogen is likely not to be very extensive if quick action is taken in removing individuals from the infection path. I will try to post a notebook when I am done with this, time allowingEnrique Garcia Moreno E.2020-02-26T16:43:12ZWhy my values of k1 & k2 are different? Help Please
https://community.wolfram.com/groups/-/m/t/1910542
Hi, My values are coming different than the answers, even though I have typed the same code as given in the paper, could you please help me out? Notebook is attached. I was expecting k1=0.062959 and k2=0.0211523Muhammad Afzal2020-03-27T10:48:11ZFind difference between two sets of scores of a single participant?
https://community.wolfram.com/groups/-/m/t/1910714
**What I am trying to do?**
I have a data set which consists of only one undergraduate student's all courses scores. Let's assume, he has completed about 70 courses where 40 courses are related to science and remaining 30 courses are related to arts. Score range of each course is 0 to 100. I am interested to find whether there exists any difference in scores of science and arts related courses. Therefore, I have divided the data; in one group (arts) of data, there are 30 values and in another group (science), there are 40 values.
**What did stop me to find the difference?**
- As there is only two groups of data, I could use Student's T Test.
However, as student's t test has assumption of independence[
\[1\]][1], I can not use that formula.
- William M Connelly answered [a question][2] of RG where he remarked
when should we use Paired T Test
> Moreover, it is basically only applicable when you have a "before" and
> "after" value recorded from a single "subject" (a subject could be a
> cell, a piece of tissue, or a human etc). Really, what it is asking is
> "is there a systematic difference between the before and after?"
Therefore, I can not use Paired T Test also.
- The same problems occurred when I wanted to use Non parametric tests
like Mann Whitney U Test or Wilcoxon Signed-Rank Test.
**My Question**
How can I find the score difference of arts related courses (30 courses) and science related courses (40 courses) when there is only one student's data and data are not paired?
**Note:** I have followed repeated measures related different questions of Stack Exchange. However, I feel sorry to say you that I did not find the answer of my question. Actually, I asked this question [here][3]. However, I failed to find the answer.
[1]: https://en.wikipedia.org/wiki/Student%27s_t-test#Assumptions
[2]: https://www.researchgate.net/post/Paired_t_test_unequal_sample_sizes
[3]: https://stats.stackexchange.com/questions/456028/how-to-find-the-difference-between-two-set-of-scores-of-a-single-participantSabbir Ahmed2020-03-27T11:08:19ZWhy does NDSolve return input with no error?
https://community.wolfram.com/groups/-/m/t/1910129
When I run the following NDSolve command, Mathematica 12.0 just spits back my input as its output, with no error messages. Why is it failing to execute? I have been all over the syntax, but can find nothing wrong.
NDSolve[{S'[t]==-10,EE'[t]==-10,I0'[t]==2-0.167122 I0[t],
I1'[t]==2-0.0714286 I1[t],I2'[t]==2-0.1 I2[t],I3'[t]==2-0.1 I3[t],
I4'[t]==2-0.0892857 I4[t],RR'[t]==0.167122 I0[t]+0.0714286 I1[t]+0.1 I2[t]+0.1 I3[t],
S[0]==399753.,EE[0]==1000,I0[0]==230.799,
I1[0]==11.4638,I2[0]==1.92257,I3[0]==1.28089,
I4[0]==1.33272,RR[0]==0},{S[t],EE[t],I0[t],I1[t],I2[t],I3[t],I4[t],RR[t]},{t,0,180}]Christopher Kribs2020-03-26T20:45:00ZMartin Gardner's 27-Card Trick on Numberphile in Slow Motion
https://community.wolfram.com/groups/-/m/t/1909911
*Playing cards + Mathematica + Numberphile + PS4 = quarantine starter pack*
----------
![demo][1]
## Abstract ##
In [this episode][2] Brady shares his favorite number with Matt and memorizes a chosen card from 27-card deck without telling Matt. Matt asks Brady same question for three times to locate the chosen card precisely at the position indicated by Brad's favorite number with modular algorithm and ternary number system.
The code in the notebook may be a little lengthy and I do not want to skip any all critical intermediate stages in this step by step walkthrough just like the *Numberphile* video. You can download all input codes at the end of this article.
## Play the Game ##
Matt draws a random deck of 27 playing cards from a standard pack of 52 cards (joker cards discarded). Set a seed for random generation so we can use the same data again.
SeedRandom[4321];
deck = RandomSample[Range[52], 27];
(* {23,41,1,19,28,52,13,31,7,51,12,27 ... } *)
Each code above corresponds to a playing card with its suits sorted in the following way
- 01 - 13: Ace to King/Spades
- 14 - 26: Ace to King/Heart
- 27 - 39: Ace to King/Diamonds
- 40 - 52: Ace to King/Clubs
We can display the deck with the following function from [Wolfram Function Repository][4]
![ace][5]
I also define the `showFullDeck` function based on `ResourceFunction["PlayingCardGraphic"]`. This function returns a `Graphics` object, therefore most options is implicitly inherited from Graphics. I added several options to control the output size, the arrangement of cards and numbered labels. The second argument controls whether I need to add a tag to highlight a card in the deck. If no value is given, the default value is zero. The logic in the `Epilog` will not create a circular tag. Otherwise, the circular tag is added at the card we choose. Because I know each card is unique, I just take the first row and first column from a `Position` function call
showFullDeck[deck_,num_:0]:=ResourceFunction["PlayingCardGraphic"][deck,
"CardSpreadAngle"->0,"CardOffset"-> {0.45,0},ImageSize->{440,145},
Epilog->{If[num==0,Nothing,
Style[ Circle[{-1+0.45 * Position[deck,num][[1,1]],1.45},{0.25,0.45}],Thick,Blue]],
Table[Text[ToString[k],{-1+0.45 * k,2.1}],{k,3,27,3}]}]//Rasterize
I can use this function to show the Matt's hand of deck. The numbers above cards are ordered in such a way that one deals the left most card first as all cards face down.
![full][6]
I can make the step-by-step demonstration a little simpler than in video. Matt asks Brady to pick up a number. Brady says it out loudly
favNumber = RandomInteger[{1, 27}]
(* 10 *)
Then Matt immediately makes the following critical calculation in head without telling Brady. First he removes 1 from the number, and converts the decimal number into base 3. Here I need to pad zero to the left of this representation so that once the digits are reversed, I still can get a list of three numbers
rTerDig = Reverse@IntegerDigits[favNumber - 1, 3, 3]
(* {0,0,1} *)
Brady is then asked to pick a secret card from the deck and he only shares the information with audience.
secretCard = RandomChoice[deck]
(* 12 *)
![sc][7]
Now Matt is going to deal the deck in this way:
deal3Piles[splittedDeck_,sc_:0]:=Framed[Rasterize@Row@Map[
ResourceFunction[PlayingCardGraphic] [#,
"CardSpreadAngle"->0,"CardOffset"-> {0.15,-0.72},
ImageSize->{100,280},
Epilog->If[MemberQ[#,sc],
Style[Circle[
{0.15 * (Position[#,sc][[1,1]]-7),-0.72*(Position[#,sc][[1,1]]-2)}
,{0.25,0.45}],Blue,Thickness[0.08]],
{}]]&,splittedDeck]]
So the first card goes to left (1st) pile, second card middle, third card right, fourth card first, fifth card middle and so on, until all 27 cards are dealt. Illustrated below. All cards are facing up on the table.
firstDeal = Transpose@Partition[deck, 3, 3];
deal3Piles[firstDeal, secretCard]
![p1][8]
Matt asks Brady to point out which pile contains the chosen card. Brady answers
pile1 = Position[firstDeal, secretCard][[1, 1]]
(* 2 *)
Matt then pile-shuffles the three group by stacking them in this order
shuffle1 = Cases[permute, _?(#[[rTerDig[[1]] + 1]] == pile1 &)][[1]]
(* {2,1,3} *)
This tuple simply means that when one needs to put three piles into one pile, the middle pile from the diagram should be decked on top of the other two piles, with all cards facing down. Once this is done, the sequence of all cards after this operation is
newDeck = Join @@ firstDeal[[shuffle1]];
showFullDeck[newDeck, secretCard]
![full2][9]
Use the above newly sorted deck and deal to 3 piles likewise
secondDeal = Transpose@Partition[newDeck, 3, 3];
deal3Piles[secondDeal, secretCard]
![pile2][10]
Matt asks Brady the second time to point out the deck containing the secret card
pile2 = Position[secondDeal, secretCard][[1, 1]]
(* 1 *)
Matt pile-shuffles again and this time the order for Matt's new deck from top to bottom is left, middle and right pile, respectively. Let's take a look at the new deck after shuffle
newDeck = Join @@ secondDeal[[shuffle2]];
showFullDeck[newDeck, secretCard]
![full3][11]
Matt deals these cards for the third time and asks Brady the same question again
thirdDeal = Transpose@Partition[newDeck, 3, 3];
deal3Piles[thirdDeal, secretCard]
![deck3][12]
Brady points out the following pile containing the secret card
pile3 = Position[thirdDeal, secretCard][[1, 1]]
(* 2 *)
Matt shuffles three piles for the last time the same way before and he concludes that
shuffle3=Cases[permute,_?(#[[rTerDig[[3]]+1]]==pile3&)][[1]];
newDeck=Join@@thirdDeal[[shuffle3]];
Framed[Style[Column[{showFullDeck[newDeck,secretCard],
Row[{"Brady has chosen ",
ResourceFunction["PlayingCardGraphic"][secretCard,ImageSize->64],
" at ",IntegerName[favNumber,{"English","Ordinal"}] ," position from left."}]}],
ImageSizeMultipliers->1,FontFamily->"Source Sans Pro",FontSize->15]]
![result][13]
##Remark##
- Readers can comment out the starting line with SeedRandom to create your own shuffled deck to begin with. Just find and click *Evaluation -> Evaluate* Notebook in toolbar to automatically generate games.
- You can find a nice proof from *Saha, Teaching the Ternary Base Using a Card Trick*
- Gardner, Martin.Mathematics, Magic and Mystery. Dover Publications 1956.
**Do not forget to checkout *[another][3]* card trick article in the community inspired by *Numberphile*.**
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=demo.gif&userId=23928
[2]: https://youtu.be/l7lP9y7Bb5g
[3]: https://community.wolfram.com/groups/-/m/t/1718762
[4]: https://resources.wolframcloud.com/FunctionRepository/resources/PlayingCardGraphic
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9072pic1.jpg&userId=23928
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic2.jpg&userId=23928
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic3.jpg&userId=23928
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic4.jpg&userId=23928
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic5.jpg&userId=23928
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic6.jpg&userId=23928
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic7.jpg&userId=23928
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic8.jpg&userId=23928
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pic9.jpg&userId=23928Shenghui Yang2020-03-26T18:46:21Z[GIF] Vanishing Point (Conformal image of a vertical grid)
https://community.wolfram.com/groups/-/m/t/1909621
![Conformal image of a vertical grid][1]
**Vanishing Point**
This is essentially the same setup as [:eyes:][2]: the map $f(z) = \frac{-4i}{z}$ maps the infinite strip $\{z \in \mathbb{C} : 1 \leq \operatorname{Re}(z) \leq 2\}$ to the region between the two circles $\{z \in \mathbb{C}: |z+i| = 1\}$ and $\{z \in \mathbb{C}: |z+2i|=2\}$, so the square grid in the strip gets mapped to a right-angled grid in the region between circles.
Code for a (very slow) `Manipulate` (see [this comment][3] for the process of exporting to GIF):
With[{r = 20, d = 11,
cols = RGBColor /@ {"#00a8cc", "#ffa41b", "#000839"}},
Manipulate[
Graphics[{EdgeForm[None],
Table[{Blend[cols[[;; 2]], (i - 1)/(Length[#] - 1)],
Polygon[Join[#[[i, 1]], Reverse[#[[i, 2]]]]]},
{i, 1, Length[#]}]
&@Partition[Table[ReIm[(-4 I)/(x + I t)], {x, 1., 2, 1/d}, {t, -50, 50, .01}], 2],
cols[[-1]],
Polygon[Join[#[[1]], Reverse[#[[2]]]]] & /@
Partition[Table[ReIm[(-4 I)/(1 + t + I (y - u))], {y, Join[Table[s, {s, -r, r, 1./d}]]}, {t, -.01, 1, .01}], 2]},
ImageSize -> 540, PlotRange -> {{-2.6, 2.6}, {-4.6, .6}},
Axes -> None, Background -> cols[[-1]]],
{u, 0, 2/d}]
]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=grid3.gif&userId=610054
[2]: https://community.wolfram.com/groups/-/m/t/1838263
[3]: https://community.wolfram.com/groups/-/m/t/1880759Clayton Shonkwiler2020-03-26T16:18:57ZSolve and plot the following equation's derivative
https://community.wolfram.com/groups/-/m/t/1910034
I am graphing the equation x^3+y^3=6xy and finding where the slopes of the tangent lines are equal to zero. So far I have graphed the original equation:
![enter image description here][1]
And I solved for the derivative:
Solve[Dt[x^3 + y^3 == 6 (x) (y), x], Dt[y, x]]
{{Dt[y, x] -> (x^2 - 2 y)/(2 x - y^2)}}
and the graph looks like this:
![enter image description here][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Loopy.png&userId=1881421
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Loopyderivative.jpg.png&userId=1881421
As you can see, the graph of the derivative has a zero at around 2.5, but the original graph looks like it's at around 3. This is confusing. Am I missing something? Did I enter the derivative equation incorrectly? Please help.Elanor Lambert2020-03-26T21:10:36ZExploraciones computacionales sobre el COVID-19
https://community.wolfram.com/groups/-/m/t/1909698
Acompáñenos en un seminario web gratuito Wolfram para compartir recursos sobre el COVID-19, los cuales incluyen análisis computacionales y visualizaciones relacionadas con la pandemia. Los conferencistas a cargo serán Tomás de Camino-Beck, PhD en Biología Matemática por la Universidad de Alberta, M.Sc. en Informática por el Instituto Tecnológico de Costa Rica y B.Sc. en Ciencias Biológicas de la Universidad de Costa Rica. El Dr. de Camino-Beck ha realizado investigaciones en el modelado de enfermedades infecciosas, invasión biológica y biología computacional. Es profesor invitado en la Universidad LEAD en Costa Rica, y ha enseñado en el Instituto de Tecnológico de Costa Rica, la Universidad de Costa Rica y la Universidad Veritas, materias desde arte y diseño hasta matemáticas e informática. En el 2008 fue galardonado por la Sociedad de Biología Matemática con el mejor artículo científico original, por su contribución a dicho campo. Actualmente se desempeña como consultor independiente en tecnología e innovación.
También presentará Francisco Rodríguez Arias, Gerente de Proyectos Avanzados de Wolfram Research South America.
Roy Álvarez, Director de Desarrollo Internacional para América Latina y el Caribe en Wolfram será el moderador.
Día y hora: 31 de Marzo, 2020. 12:00pm – Horario Central de los Estados Unidos
Formulario de inscripción: https://register.gotowebinar.com/register/1622371593985826316Roy Alvarez2020-03-26T18:13:20ZProblem with a Fourier Transform result
https://community.wolfram.com/groups/-/m/t/1906215
Consider the following code:
In[22]:= FourierTransform[Exp[I u t],t, \[Omega]]
Out[22]= Sqrt[2 \[Pi]] DiracDelta[u+\[Omega]]
While,
In[25]:= FourierTransform[Sqrt[2 Pi]DiracDelta[u+\[Omega]],\[Omega],t]
Out[25]= E^(-I t u)
In addition the coefficient are supposed to be `2 Pi` instead of `Sqrt[2 Pi]`Ss Lite2020-03-24T09:17:56ZProblem to solve simultaneous equations
https://community.wolfram.com/groups/-/m/t/1907460
Hi,
I have problems to solve simultaneous equations!
The NSolve command also does not lead to a solution.
Mathematica runs the whole night, but does not give any solutions.
Have anybody an idea?
Thanks for your help!Chi Nghia Chung2020-03-25T06:10:02ZWhat is quantum calculus?
https://community.wolfram.com/groups/-/m/t/1909106
[quantum calculus][1] is an elegant blog managed by [Oliver Knill][2], a Harvard mathematician, covering an interesting range of advanced topics. Why I've posted it here is that many of the posts use *Mathematica*/WL for the symbolic analysis and graphical output, and some of the code is included in the posts. It would, of course, be nice if these were Wolfram Cloud documents, but there's still plenty of great stuff to read and digest.
[1]: https://www.quantumcalculus.org/
[2]: http://people.math.harvard.edu/~knill/Paul Abbott2020-03-26T07:33:42ZUsing Manipulate with NDSolve expression of two differential equations
https://community.wolfram.com/groups/-/m/t/1902159
Hell,
I am trying to model a physical system. The system composes of two partial differential equations with initial conditions defined.
I wrote the code and everything works fine, just except me trying to manipulate one of the parameters and I appreciate if anyone can suggest me a solution
The code is as follows.
ClearAll["Global`*"] (*Remove all global variables*)
gamma[alpha1_] := 1/(1 + alpha1^2);
hexternal = {1, 0, 0};
hxexternal = hexternal[[1]];
hyexternal = hexternal[[2]];
hzexternal = hexternal[[3]];
equationM1[
alpha1_] := {M1'[t] ==
gamma[alpha1]*(alpha1*((Cos[M1[t]]*Cos[M2[t]])*
hxexternal + (Cos[M1[t]]*Sin[M2[t]])*hyexternal -
Sin[M1[t]]*hzexternal) + ((-Sin[M2[t]])*
hxexternal + (Cos[M2[t]])*hyexternal))};
equationM2 [
alpha1_] := {M2'[t] ==
gamma[alpha1]*((-1/
Sin[M1[t]])*((Cos[M1[t]]*Cos[M2[t]])*
hxexternal + (Cos[M1[t]]*Sin[M2[t]])*hyexternal -
Sin[M1[t]]*hzexternal) + (alpha1/
Sin[M1[t]])*((-Sin[M2[t]])*hxexternal + (Cos[M2[t]])*
hyexternal))};
initial1 = {M1[0] == Pi/2 + 0.01}
initial2 = {M2[0] == Pi + 0.01}
eqns[alpha1_] :=
Join[equationM1[alpha1], equationM2[alpha1], initial1, initial2];
Manipulate[
sol1 = NDSolve[eqns[alpha1], {M1[t], M2[t]}, {t, 0, 100},
StartingStepSize -> 1/100,
Method -> {"FixedStep", Method -> "ExplicitEuler"}];
{M1[t], M2[t]} = {M1[t], M2[t]} /. sol1[[1]];
x = Sin[M1[t]]*Cos[M2[t]];
y = Sin[M1[t]]*Sin[M2[t]];
z = Cos[M1[t]];
ParametricPlot3D[{x, y, z}, {t, 0, 100}, PlotRange -> 1,
BoxRatios -> {1, 1, 1}, AxesLabel -> {X, Y, Z}],
{alpha1, 0.1, 1}]Abdlerahman Qoutb2020-03-19T22:33:56ZHow is FourierParameters processed in the function.
https://community.wolfram.com/groups/-/m/t/1907478
In the Wolfram documentation, It is only list a few classical `FourierParameters` value and their using scene.
But the content of `FourierParameters` are two integer.
How this two value affect the final result of fourier analysis function?
What is the formula of these parameter toward final result?Ss Lite2020-03-25T08:14:36Z