0
$\begingroup$

I would like to speed up this following function:

assignvalue[xval_, zval_] := 
Module[{xtest = 
  Flatten[Position[IntervalMemberQ[#, N[xval]] & /@ intdomain, 
    True]]},
Reverse[
 SortBy[Select[
   Partition[
    Riffle[Map[inter[[#]][x] &, xtest] /. x -> N[xval], 
     values[[#]] & /@ xtest], 2], #[[1]] < N[zval] &], First]]][[
 1, 2]];

Function should assign value (value from the list values) to the point (point defined by some xval and zval), based on the position of point with respect to the closest curve in the z direction, lying below the point.

Additional inforamtion, random test data and values :
There is 100 + 2 curves, which were created by data interpolation. Data and values are shown below

m = 100;
n = 100;
offset = {-5, 5};
numbofxvalues = 10;
xvalues = Table[RandomReal[{0, n}, numbofxvalues], {i, 1, m}];
f[x_, z_] := {x, z};
maxzvalues = 1000;
di = maxzvalues/m
veryfirstline = {{1, 1 + offset[[1]]}, {n, 1 + offset[[1]]}};
verylastline = {{1, maxzvalues + offset[[2]]}, {n, 
maxzvalues + offset[[2]]}};

data = SortBy[#, First] & /@ 
Module[{k = 1}, 
Table[(# + {0, RandomReal[offset]}) & /@ (f[#, i] & /@ 
    xvalues[[k++]]), {i, 1, maxzvalues, di}]];
data = Join[{veryfirstline}, {verylastline}, data];
values = Range[Length@data];

Interpolation is shown here

inter = Table[Unique[inter$], {i, 1, Length@data}];
Table[inter[[i]] = 
Interpolation[data[[i]], InterpolationOrder -> 1], {i, 1, 
Length@data}];
intdomain = 
Interval[#] & /@ 
Flatten[Table[(inter[[i]])["Domain"], {i, 1, Length@data}], 1];

I am applying function assignvalue to list of pairs (called grid). List grid represents points in 2D space.

gridstepx = n/800;
gridstepz = maxzvalues/800;
grid = Table[{N[i], N[j]}, {i, 1, n, gridstepx}, {j, 1, maxzvalues, 
gridstepz}];

Application of function assignvalue to values in grid is shown below

solutions = Apply[assignvalue, #, {1}] & /@ grid; // AbsoluteTiming
(*Output:*)
{1194.12, Null}

Computation of solutions took on my machine 1194.12 seconds. If somebody could think of some speeding up the evaluation of this function, I will be very grateful. The parallel implementation will be also accepted as an answer since I can use 2 subkernels for parallel computation.

Example
For some given coordinates of point (xpoint and zpoint) the function will at first go throug all the interpolation intervals (intdomain) and will pick only those curves for which xpoint(highlighted by dashed Blue line) lies in interpolation interval of some particular curve (curves satisfying this criterion are plotted in Green colour). After that the function will idetify the "serial "number/"name" of curve (curves are denoted by number from values list) which lies below the point a it is closest to this point (solution curve plotted in Red colour).

xpoint = 5;(*x coordinate of example point*)
zpoint = 507;(*z coordinate of example point*)
curveswithsamexpoint = 
Flatten[Position[IntervalMemberQ[#, N[xpoint]] & /@ intdomain, 
True]];(*curves satisfying criterion*)

Show[Table[
Plot[Tooltip[inter[[i]][x], values[[i]]], {x, intdomain[[i, 1, 1]], 
intdomain[[i, 1, 2]]}, 
PlotRange -> {{1, n}, {1 - 5, maxzvalues + 5}}, 
PlotStyle -> 
Which[i == assignvalue[xpoint, zpoint], Red, 
MemberQ[curveswithsamexpoint, i], 
Green, ! MemberQ[curveswithsamexpoint, i], Black], 
Epilog -> {PointSize[Large], Red, Point[{xpoint, zpoint}], Blue, 
Dashed, Line[{{xpoint, 1 + offset[[1]]}, {xpoint, 
maxzvalues + offset[[2]]}}]}], {i, 1, Length@data}]]

enter image description here

$\endgroup$
  • 2
    $\begingroup$ Could you explain in a bit more detail what you want to achieve? (preferably with a more minimal example) As it stands, it is very difficult to understand what your current version is doing exactly $\endgroup$ – Lukas Lang Nov 17 '18 at 14:05
  • $\begingroup$ @LukasLang, I added an example $\endgroup$ – Moonwalk Nov 17 '18 at 19:28
  • $\begingroup$ Are you at all able to minimize this? There is a direct correlation between how minimal the problem is (in its current form, it really isn't minimized) and how much help you're likely to get on the question. $\endgroup$ – user6014 Nov 17 '18 at 19:56

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.