I tried to create a function to manipulate an image, where I can adjust some value color1, color2, val1, val2 and num and see the effect on image. Below is my code for processing an image with fixed values for color1, color2, val1, val2 and num.
How can I do it?
val1 = 0.4;
val2 = 0.4
num = 2000
color1 = Red
color2 = Black
imageno = 1;
img = images[[imageno]];
DeleteSmallComponents[
MorphologicalComponents[
RemoveBackground[img, {"Foreground", {color1, val1}}], num]];
im = RemoveBackground[img, {"Foreground", {color2, val2}}];
ima = EdgeDetect[im];
cen = ComponentMeasurements[
ima, {"Centroid"}, #Holes == 1 &&
10 < #Area && #AdjacentBorderCount == 0 &];
b = Flatten[cen /. Rule -> List, 2]; (* remove arrow*)
(*sort out even and odd element, even elements contain coordinate for \
hole*)
{x, y} = Partition[b, 2, 2, 1, {}]~Flatten~{2};
(*y : hole centroid location*)
dm = DelaunayMesh[y];
v = MeshPrimitives[dm, 0];
t = MeshPrimitives[dm, 2];
vedg = Length[Position[Level[t, {2}], #]] & /# Level[v, {2}];
kN = Max[vedg];
mnloc = Flatten[Position[vedg, kN]];
mntri = Flatten[
Position[ContainsAny[#, Level[v[[mnloc]], {2}]] & /# Level[t, {2}],
True]];
nc = t[[mntri]];
knpic = Graphics[{Red, {PointSize[0.01], Point[y]}, Green,
MeshPrimitives[dm, 1], {Opacity[0.5], FaceForm[Red],
EdgeForm[{Thick, Red}], nc, FaceForm[Yellow]}}];
Show[img, knpic, ImageSize -> 500]
Related
Below code is used to solve a stochastic equation numerically in Mathematica for one particle. I wonder if there is a way to generalize it to the case of more than one particle and average over them. Is there anyone who knows how to do that?
Clear["Global`*"]
{ a = Pi, , b = 2 Pi, l = 5, k = 1};
ic = x#tbegin == 1;
tbegin = 1;
tend = 400;
interval = {1, 25};
lst := NestWhileList[(# + RandomVariate#TruncatedDistribution[interval,
StableDistribution[1, 0.3, 0, 0, 1]]) &, tbegin, # < tend &];
F[t_] := Piecewise[{{k, Or ## #}}, -k] &[# <= t < #2 & ###
Partition[lst, 2]];
eqn := x'[t] == (F#(t)) ;
sol = NDSolveValue[{eqn, ic}, x, {t, tbegin, tend},
MaxSteps -> Infinity];
Plot[sol#t, {t, tbegin, tend}]
First[First[sol]]
Plot[sol'[t], {t, tbegin, tend}]
Plot[F[t], {t, tbegin, tend}]
I am beginner in Mathematica. I write code in mathematica for finding parametric fractal dimension. But it doesn't work. Can someone explain me where I am wrong.
My code is:
delta[0] = 0.001
lambda[0] = 0
div = 0.0009
a = 2
b = 2
terms = 100
fx[0] = NSum[1/n^b, {n, 1, terms}]
fy[0] = 0
For[i = 1, i < 11, i++,
delta[i] = delta[i - 1] + div;
j = 0
While[lambda[j] <= Pi,
j = j + 1;
lambda[j] = lambda[j - 1] + delta[i];
fx[j] = NSum[Cos[n^a*lambda[j]]/n^b, {n, 1, terms}];
fy[j] = NSum[Sin[n^a*lambda[j]]/n^b, {n, 1, terms}];
deltaL[j] = Sqrt[[fx[j] - fx[j - 1]]^2 + [fy[j] - fy[j - 1]]^2];
]
Ldelta[i] = Sum[deltaL[j], {j, 1, 10}];
]
data = Table[{Log[delta[i]], Log[Ldelta[i]]}, {i, 1, 10}]
line = Fit[data, {1, x}, x]
ListPlot[data]
I am trying to solve an D-equation and do not know y[0], but I know y[x1]=y1.
I want to solve the DSolve only in the relevant xrange x=[x1, infinitny].
How could it work?
Attached the example that does not work
dsolv2 = DSolve[{y'[x] == c*0.5*t12[x, l2]^2 - alpha*y[x], y[twhenrcomesin] == zwhenrcomesin, x >= twhenrcomesin}, y[x], x]
dsolv2 = Flatten[dsolv2]
zsecondphase[x_] = y[x] /. dsolv2[[1]]
I am aware that DSolve does not allow the inequality condition but I put it in to explain you what I am looking for (t12[x,l2] will give me a value only depending on x since l2 is known).
EDIT
t12[j24_, lambda242_] := (cinv1 - cinv2)/(cop2 - cop1 + (h2*lambda242)*E^(p*j24));
cinv1 = 30; cinv2 = 4; cinv3 = 3; h2 = 1.4; h3 = 1.2; alpha = 0.04; z = 50; p = 0.06; cop1 = 0; cop2 = 1; cop3 = 1.3; teta2 = 0.19; teta3 =0.1; co2 = -0.6; z0 = 10;l2 = 0.1;
Your equation is first order and linear, so you can get a very general solution :
generic = DSolve[{y'[x] == f[x] - alpha*y[x], y[x0] == y0}, y[x], x]
Then you can substitute your specific term :
c = 1;
x0 = 1;
y0 = 1;
solution[x_] = generic[[1, 1, 2]] /. {f[x_] -> c*0.5*t12[x, l2]^2}
Plot[solution[x], {x, x0, 100}]
What is wrong with this example?
t12[x_] := Exp[-x .01] Sin[x];
dsolv2 = Chop#DSolve[{y'[x] == c*0.5*t12[x]^2 - alpha*y[x], y[1] == 1}, y[x], x];
Plot[y[x] /. dsolv2[[1]] /. {alpha -> 1, c -> 1}, {x, 1, 100}, PlotRange -> Full]
Edit
Regarding your commentary:
Try using a piecewise function to restrict the domain:
t12[x_] := Piecewise[{{ Exp[-x .01] Sin[x], x >= 1}, {Indeterminate, True}}] ;
dsolv2 = Chop#DSolve[{y'[x] == c*0.5*t12[x]^2 - alpha*y[x], y[1] == 1}, y[x], x];
Plot[y[x] /. dsolv2[[1]] /. {alpha -> 1, c -> 1}, {x, 1, 100}, PlotRange -> Full]
I have several 100x15 matrices; one of them is a distance. When elements of that matrix exceed a bound, I want to reset those elements to zero and also reset the corresponding elements of three other matrices to zero. Here's my silly way (but it works):
Do[ If[ xnow[[i, j]] > L, xnow[[i, j]] = 0.;
cellactvA[[i, j ]] = 0.;
cellactvB[[i, j ]] = 0.;
cellactvC[[i, j ]] = 0.; ], (* endIF *)
{ i, 1, nstrips}, {j, 1, ncells} ]; (* endDO *)
I tried ReplacePart:
xnow = ReplacePart[ xnow, Position[ xnow, x_?(# > L &) ] ]
(something like this, I don't have it handy; it was done correctly enough to execute), but it was as slow as the loop and did not produce the correct replacement structure in matrix xnow. Please advise on how to do this in a way that is reasonably quick, as this calc is inside another loop (over time) that executes many many times. The overall calculation is of course, now, very slow. Thanks in advance.
Here is how I did this in R; very simple and quick:
# -- find indices of cells outside window
indxoutRW <- which( xnow > L, arr.ind=T )
# -- reset cells outside window
cellrateA[indxoutRW] <- 0
cellrateB[indxoutRW] <- 0
cellrateC[indxoutRW] <- 0
# -- move reset cells back to left side
xnow[indxoutRW] <- xnow[indxoutRW] - L
How about this:
Timing[
matrixMask2 = UnitStep[limit - $xnow];
xnow = $xnow*matrixMask2;
cellactvA2 = $a*matrixMask2;
cellactvB2 = $b*matrixMask2;
cellactvC2 = $c*matrixMask2;
]
If you want to write fast code one thing to make sure is to check that On["Packing"] does not gives messages; or at least that you understand them and know that they are not an issue.
Edit for OP comment:
mask = UnitStep[limit - xnow];
{xnow*mask, cellactvA2*mask, cellactvB2*mask, cellactvC2*mask}
Hope this helps, you still need to set limit.
The following will be based on SparseArrays, avoid extraneous stuff and very fast:
extractPositionFromSparseArray[
HoldPattern[SparseArray[u___]]] := {u}[[4, 2, 2]];
positionExtr[x_List, n_] :=
extractPositionFromSparseArray[
SparseArray[Unitize[x - n], Automatic, 1]]
replaceWithZero[mat_, flatZeroPositions_List, type : (Integer | Real) : Real] :=
Module[{copy = Flatten#mat},
copy[[flatZeroPositions]] = If[type === Integer, 0, 0.];
Partition[copy, Last[Dimensions[mat]]]];
getFlatZeroDistancePositions[distanceMat_, lim_] :=
With[{flat = Flatten[distanceMat]},
With[{originalZPos = Flatten# positionExtr[flat , 0]},
If[originalZPos === {}, #, Complement[#, originalZPos ]] &#
Flatten#positionExtr[Clip[flat , {0, lim}, {0, 0}], 0]]];
Now, we generate our matrices, making sure that they are packed:
{xnow, cellactvA, cellactvB, cellactvC} =
Developer`ToPackedArray /# RandomReal[10, {4, 100, 15}];
Here is the benchmark for doing this 1000 times:
In[78]:=
Do[
With[{L = 5},
With[{flatzpos = getFlatZeroDistancePositions[xnow,L]},
Map[replaceWithZero[#,flatzpos ]&,{xnow,cellactvA,cellactvB,cellactvC}]]
],
{1000}]//Timing
Out[78]= {0.203,Null}
Note that there was no unpacking in the process, but you have to ensure that you have your matrices packed from the start, and that you pick the correct type (Integer or Real) for the replaceWithZero function.
Yet another method which seems to be fast
xnow = $xnow; a = $a; b = $b; c = $c;
umask = Unitize#Map[If[# > limit, 0, #] &, xnow, {2}];
xnow = xnow*umask; a = a*umask; b = b*umask; c = c*umask;
Based on limited testing in Nasser's setup it seems it is as fast as the SparseArray-based mask.
Edit: Can combine with SparseArray to get a slight speed-up
umask2=SparseArray[Unitize#Map[If[# > limit, 0, #] &, xnow, {2}]];
xnow = xnow*umask2; a = a*umask2; b = b*umask2; c = c*umask2;
Edit 2: Inspired by ruebenko's solution, another built-in function (not nearly as fast as UnitStep but much faster than others):
umask3 = Clip[xnow, {limit, limit}, {1, 0}];
xnow = xnow*umask3; a = a*umask3; b = b*umask3; c = c*umask3;
Does this approach work for you?
matrixMask =
SparseArray[Thread[Position[xnow, _?(# > 0.75 &)] -> 0.],
Dimensions[xnow], 1.];
xnow = xnow * matrixMask;
cellactvA = cellactvA * matrixMask;
cellactvB = cellactvB * matrixMask;
cellactvC = cellactvC * matrixMask;
The basic idea is to create a matrix that is zero where your threshold is crossed, and one everywhere else. Then we use element-wise multiplication to zero out the appropriate elements in the various matrices.
ReplacePart is notoriously slow.
MapThread should do what you want - note the third argument.
{xnow, cellactvA, cellactvB, cellactvC} =
RandomReal[{0, 1}, {4, 10, 5}]
L = 0.6;
MapThread[If[#1 > L, 0, #2] &, {xnow, xnow}, 2]
And for all four matrices
{xnow, cellactvA, cellactvB, cellactvC} =
MapThread[Function[{x, y}, If[x > L, 0, y]], {xnow, #},
2] & /# {xnow, cellactvA, cellactvB, cellactvC}
may be
(*data*)
nRow = 5; nCol = 5;
With[{$nRow = nRow, $nCol = nCol},
xnow = Table[RandomReal[{1, 3}], {$nRow}, {$nCol}];
cellactvA = cellactvB = cellactvC = Table[Random[], {$nRow}, {$nCol}]
];
limit = 2.0;
now do the replacement
pos = Position[xnow, x_ /; x > limit];
{cellactvA, cellactvB, cellactvC} =
Map[ReplacePart[#, pos -> 0.] &, {cellactvA, cellactvB, cellactvC}];
edit(1)
Here is a quick speed comparing the 4 methods above, the LOOP, and then Brett, me, and Verbeia. May be someone can double check them. I used the same data for all. created random data once, then used it for each test. Same limit (called L) I used matrix size of 2,000 by 2,000.
So speed Timing numbers below does not include data allocation.
I run the tests once.
This is what I see:
For 2,000 by 2,000 matrices:
Bill (loop): 16 seconds
me (ReplacPart): 21 seconds
Brett (SparseArray): 7.27 seconds
Verbeia (MapThread): 32 seconds
For 3,000 by 3,000 matrices:
Bill (loop): 37 seconds
me (ReplacPart): 48 seconds
Brett (SparseArray): 16 seconds
Verbeia (MapThread): 79 seconds
So, it seems to be that SparseArray is the fastest. (but please check to make sure I did not break something)
code below:
data generation
(*data*)
nRow = 2000;
nCol = 2000;
With[{$nRow = nRow, $nCol = nCol},
$xnow = Table[RandomReal[{1, 3}], {$nRow}, {$nCol}];
$a = $b = $c = Table[Random[], {$nRow}, {$nCol}]
];
limit = 2.0;
ReplacePart test
xnow = $xnow;
a = $a;
b = $b;
c = $c;
Timing[
pos = Position[xnow, x_ /; x > limit];
{xnow, a, b, c} = Map[ReplacePart[#, pos -> 0.] &, {xnow, a, b, c}]][[1]]
SparseArray test
xnow = $xnow;
a = $a;
b = $b;
c = $c;
Timing[
matrixMask =
SparseArray[Thread[Position[xnow, _?(# > limit &)] -> 0.],
Dimensions[xnow], 1.]; xnow = xnow*matrixMask;
a = a*matrixMask;
b = b*matrixMask;
c = c*matrixMask
][[1]]
MapThread test
xnow = $xnow;
a = $a;
b = $b;
c = $c;
Timing[
{xnow, a, b, c} =
MapThread[Function[{x, y}, If[x > limit, 0, y]], {xnow, #},
2] & /# {xnow, a, b, c}
][[1]]
loop test
xnow = $xnow;
a = $a;
b = $b;
c = $c;
Timing[
Do[If[xnow[[i, j]] > limit,
xnow[[i, j]] = 0.;
a[[i, j]] = 0.;
b[[i, j]] = 0.;
c[[i, j]] = 0.
],
{i, 1, nRow}, {j, 1, nCol}
]
][[1]]
edit(2)
There is something really bothering me with all of this. I do not understand how a loop can be faster that the specialized commands for this purpose?
I wrote a simple loop test in Matlab, like Bill had using R, and I getting much lower timings there also. I hope an expert can come up with a much faster method, because now I am not too happy with this.
For 3,000 by 3,000 matrix, I am getting
Elapsed time is 0.607026 seconds.
This is more than 20 times faster than the SparseArray method, and it is just a loop!
%test, on same machine, 4GB ram, timing uses cpu timing using tic/toc
%allocate data
nRow = 3000;
nCol = 3000;
%generate a random matrix of real values
%between 1 and 3
xnow = 1 + (3-1).*rand(nRow,nRow);
%allocate the other 3 matrices
a=zeros(nRow,nCol);
b=a;
c=b;
%set limit
limit=2;
%engine
tstart=tic;
for i=1:nRow
for j=1:nCol
if xnow(i,j) > limit
xnow(i,j) = 0;
a(i,j) = 0;
b(i,j) = 0;
c(i,j) = 0;
end
end
end
toc(tstart)
fyi: using cputime() gives similar values.as tic/toc.
When I was trying to find the maximum value of f using NMaximize, mathematica gave me a error saying
NMaximize::cvdiv: Failed to converge to a solution. The function may be unbounded.
However, if I scale f with a large number, say, 10^5, 10^10, even 10^100, NMaximize works well.
In the two images below, the blue one is f, and the red one is f/10^10.
Here come my questions:
Is scaling a general optimization trick?
Any other robust, general workarounds for the optimizations such
needle-shape functions?
Because the scaling barely changed the shape of the needle-shape of
f, as shown in the two images, how can scaling work here?
thanks :)
Update1: with f included
Clear["Global`*"]
d = 1/100;
mu0 = 4 Pi 10^-7;
kN = 97/100;
r = 0.0005;
Rr = 0.02;
eta = 1.3;
e = 3*10^8;
s0 = 3/100;
smax = 1/100; ks = smax/s0;
fre = 1; tend = 1; T = 1;
s = s0*ks*Sin[2*Pi*fre*t];
u = D[s, t];
umax = N#First[Maximize[u, t]];
(*i=1;xh=0.1;xRp=4.5`;xLc=8.071428571428573`;
i=1;xh=0.1;xRp=4.5;xLc=8.714285714285715;*)
i = 1; xh = 0.1; xRp = 5.5; xLc = 3.571428571428571`;
(*i=1;xh=0.1`;xRp=5.`;xLc=6.785714285714287`;*)
h = xh/100; Rp = xRp/100; Lc = xLc/100;
Afai = Pi ((Rp + h + d)^2 - (Rp + h)^2);
(*Pi (Rp-Hc)^2== Afai*)
Hc = Rp - Sqrt[Afai/Pi];
(*2Pi(Rp+h/2) L/2==Afai*)
L = (2 Afai)/(\[Pi] (h + 2 Rp));
B = (n mu0 i)/(2 h);
(*tx = -3632B+2065934/10 B^2-1784442/10 B^3+50233/10 B^4+230234/10 \
B^5;*)
tx = 54830.3266978739 (1 - E^(-3.14250266080741 B^2.03187556833859));
n = Floor[(kN Lc Hc)/(Pi r^2)] ;
A = Pi*(Rp^2 - Rr^2);
b = 2*Pi*(Rp + h/2);
(* -------------------------------------------------------- *)
Dp0 = 2*tx/h*L;
Q0 = 0;
Q1 = ((1 - 3 (L tx)/(Dp h) + 4 (L^3 tx^3)/(Dp^3 h^3)) Dp h^3)/(
12 eta L) b;
Q = Piecewise[{{Q1, Dp > Dp0}, {Q0, True}}];
Dp = Abs[dp[t]];
ode = u A - A/e ((s0^2 - s^2)/(2 s0 )) dp'[t] == Q*Sign[dp[t]];
sol = First[
NDSolve[{ode, dp[0] == 0}, dp, {t, 0, tend} ,
MaxSteps -> 10^4(*Infinity*), MaxStepFraction -> 1/30]];
Plot[dp''[t] A /. sol, {t, T/4, 3 T/4}, AspectRatio -> 1,
PlotRange -> All]
Plot[dp''[t] A /10^10 /. sol, {t, T/4, 3 T/4}, AspectRatio -> 1,
PlotRange -> All, PlotStyle -> Red]
f = dp''[t] A /. sol;
NMaximize[{f, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^5, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^5, T/4 <= t <= 3 T/4}, t]
NMaximize[{f/10^10, T/4 <= t <= 3 T/4}, t]
update2: Here comes my real purpose. Actually, I am trying to make the following 3D region plot. But I found it is very time consuming (more than 3 hours), any ideas to speed up this region plot?
Clear["Global`*"]
d = 1/100;
mu0 = 4 Pi 10^-7;
kN = 97/100;
r = 0.0005;
Rr = 0.02;
eta = 1.3;
e = 3*10^8;
s0 = 3/100;
smax = 1/100; ks = smax/s0;
f = 1; tend = 1/f; T = 1/f;
s = s0*ks*Sin[2*Pi*f*t];
u = D[s, t];
umax = N#First[Maximize[u, t]];
du[i_?NumericQ, xh_?NumericQ, xRp_?NumericQ, xLc_?NumericQ] :=
Module[{Afai, Hc, L, B, tx, n, A, b, Dp0, Q0, Q1, Q, Dp, ode, sol,
sF, uF, width, h, Rp, Lc},
h = xh/100; Rp = xRp/100; Lc = xLc/100;
Afai = Pi ((Rp + h + d)^2 - (Rp + h)^2);
Hc = Rp - Sqrt[Afai/Pi];
L = (2 Afai)/(\[Pi] (h + 2 Rp));
B = (n mu0 i)/(2 h);
tx = 54830.3266978739 (1 - E^(-3.14250266080741 B^2.03187556833859));
n = Floor[(kN Lc Hc)/(Pi r^2)] ;
A = Pi*(Rp^2 - Rr^2);
b = 2*Pi*(Rp + h/2);
Dp0 = 2*tx/h*L;
Q0 = 0;
Q1 = ((1 - 3 (L tx)/(Dp h) + 4 (L^3 tx^3)/(Dp^3 h^3)) Dp h^3)/(
12 eta L) b;
Q = Piecewise[{{Q1, Dp > Dp0}, {Q0, True}}];
Dp = Abs[dp[t]];
ode = u A - A/e ((s0^2 - s^2)/(2 s0 )) dp'[t] == Q*Sign[dp[t]];
sol = First[
NDSolve[{ode, dp[0] == 0}, dp, {t, 0, tend} , MaxSteps -> 10^4,
MaxStepFraction -> 1/30]];
sF = ParametricPlot[{s, dp[t] A /. sol}, {t, 0, tend},
AspectRatio -> 1];
uF = ParametricPlot[{u, dp[t] A /. sol}, {t, 0, tend},
AspectRatio -> 1];
tdu = NMaximize[{dp''[t] A /10^8 /. sol, T/4 <= t <= 3 T/4}, {t,
T/4, 3 T/4}, AccuracyGoal -> 6, PrecisionGoal -> 6];
width = Abs[u /. tdu[[2]]];
{uF, width, B}]
RegionPlot3D[
du[1, h, Rp, Lc][[2]] <= umax/6, {h, 0.1, 0.2}, {Rp, 3, 10}, {Lc, 1,
10}, LabelStyle -> Directive[18]]
NMaximize::cvdiv is issued if the optimum improved a couple of orders of magnitude during the optimization process, and the final result is "large" in an absolute sense. (To prevent the message in a case where we go from 10^-6 to 1, for example.)
So yes, scaling the objective function can have an effect on this.
Strictly speaking this message is a warning, and not an error. My experience is that if you see it, there's a good chance that your problem is unbounded for some reason. In any case, this warning is a hint that you might want to double check your system to see if that might be the case.