7
$\begingroup$

Looking at the problem of a random walk in 2D or 3D, I would like to generate several trajectories that start all in some starting point, say, (0,0) in 2D and (0,0,0) in 3D and end up all in a specified point, say (20,20) in 2D or (20,20,0) in 3D and have the same number of steps, say, 100. All steps are of the same length, say, 1. The solution may be on a lattice, or lattice-free. The initial and final coordinates are not constrained. What is important is that the overall walk length is larger than the end-to-end distance. Any ideas for a realization?

Edit

Thanks to the comment of shrx below I came to such a version of the solution:

proc = BrownianBridgeProcess[];
Show[{
  Graphics3D[
   Table[{Hue[i/16], 
     Tube@Line[
       MapThread[
        Append[#1, #2[[2]]] &, {RandomFunction[proc, {0, 1, 0.1}, 3][
          "Path"], 
         RandomFunction[proc, {0, 1, 0.1}, 3]["Path"]}]]}, {i, 1, 
     10}]],
  Graphics3D[{Arrowheads[0.06], Red, 
    Arrow[Tube[{{0, 0, 0}, {1, 0, 0}}, 0.02]]}],
  Graphics3D[
   Text[Style["\!\(\*OverscriptBox[\(R\), \(\[RightVector]\)]\)", 24, 
     Red, Bold, Italic], {0.5, 0, 0.15}]]
  }]

looking as follows:

enter image description here

where the end-to-end vector is shown in red for clearness. I cannot, however, figure out how to change the length. That is, my end-to-end vector is {{0,0,0},{0,1,0}}. It seems that I should simply replace 1, say, by 10, to have the end-to-end vector {{0,0,0},{0,10,0}} in the RandomFunction expression

RandomFunction[proc, {0, 1, 0.1}, 3]["Path"]

This does not work, however, for reasons I do not see.

$\endgroup$
  • 2
    $\begingroup$ BrownianBridgeProcess seems promising, but the steps are not of the same length. $\endgroup$ – shrx Mar 23 '15 at 14:22
  • $\begingroup$ @shrx, Thank you. Why not to formulate this as a regular answer, so that I could up-vote it? $\endgroup$ – Alexei Boulbitch Mar 23 '15 at 15:46
  • $\begingroup$ Sorry, I won't have access to a computer with Mathematica until tomorrow. $\endgroup$ – shrx Mar 23 '15 at 17:24
  • 1
    $\begingroup$ The proposed solution is highly constrained: all steps have projections along the beginning-to-end vector ${\bf R}$ that are monotonic. It is impossible to get loop-backs, retracings, self-intersections and numerous other classes of solutions that should be allowed by the problem statement. $\endgroup$ – David G. Stork Mar 23 '15 at 22:06
5
$\begingroup$

EDIT: Refactored code. Old code can be found in the end of the answer.

Initial settings. We take 20 lattice-free unit steps starting from {10, 0, 0}. Four such paths are calculated.

steps = 20;
start = {10, 0, 0};
paths = 4;

We do this in three dimensions, and whenever we perform random sampling, we strive for 10000 samples.

dims = 3;
samples = 10000;

An uniformly distributed unit-length lattice-free random walk step in dim dimensions can be computed using this trick. This function computes the resulting position after steps.

ClearAll[randomWalk]; 
randomWalk[steps_, dim_] := 
 Total[Normalize /@ 
   RandomVariate[NormalDistribution[0, 1], {steps, dim}]]

The core idea of this answer is to use probability distributions which represent likelihood of reaching origin in certain amount of unit-length random walk steps. These distributions are estimated from sample walks, for which in this fully symmetric case the distance covered is the only interesting parameter.

This function is used to compute parameter estimators for PERTDistribution, which is really a nicely reparameterized variant of BetaDistribution. It is left as an exercise to the reader to observe that distributions of distances from origin after N steps can be approximated with beta distribution.

ClearAll[distributionEstimates]; 
distributionEstimates[steps_, dim_, samples_, estimates_] := 
 NonlinearModelFit[#, a Sqrt[x] + b, {a, b}, x]["Function"] & /@ 
  Transpose@
   ParallelTable[{{n, a}, {n, b}} /. 
     FindDistributionParameters[
      Table[Norm@randomWalk[n, dim], {samples}], 
      PERTDistribution[{0, n}, a, b], 
      MapThread[{#1, #2@n} &, {{a, b}, estimates}]], {n, 2, steps}]

This is slightly tricky, but the goal is to fit parameter estimation functions better and better and produce distribution parameter estimation functions which give robustness to EstimatedDistribution in the next step.

ClearAll[estimates];
estimates = 
  Last@NestWhile[
    Apply[{2 #1, 
       distributionEstimates[steps, dims, #1, #2]} &], {100, {Sqrt, 
      Sqrt}}, First@# < 2 samples &];

Here we compute an array of functions providing PDF of random walk covering certain distance. This information is used to drive the actual source-to-destination random walk later on. Distributions for walks of 0 and 1 steps are not computed, because they're both useless for our method, and also too much for EstimatedDistribution to handle.

ClearAll[stepWeightFunctions]; 
stepWeightFunctions[steps_, dim_, samples_, estimates_] := 
 ParallelTable[
  PDF@EstimatedDistribution[Table[Norm@randomWalk[n, dim], {samples}],
     PERTDistribution[{0, n}, a, b], 
    MapThread[{#1, #2@n} &, {{a, b}, estimates}]], {n, 2, steps}]

We compute weights for our case here. These functions could be reused later on.

ClearAll[weightFunctions];
weightFunctions = stepWeightFunctions[steps, dims, samples, estimates];

This is the core of our solution. It simply performs weighted RandomChoice walk form source. Weights are calculated on basis of distance of candidate step from the origin, and amount of steps left.

Two last steps are not computed this way, because last step is always origin, and second-last step lies on intersection of two predetermined spheres. This can't be accomplished with dumb random step candidates.

ClearAll[incompleteWalks];
incompleteWalks = 
  ParallelTable[
   Last /@ NestList[
     Apply[Function[{level, pt}, {level - 1, 
        pt + (RandomChoice[
             weightFunctions[[level - 1]]@Norm[pt + #] & /@ # -> #] &[
           Table[randomWalk[1, dims], {samples}]])}]], {steps - 1, 
      start}, steps - 2], {paths}];

Walks are completed by FindInstance which provides a step that satisfies above constraints. FindInstance isn't really random, but given all the other randomness in this routine, this might be good enough.

ClearAll[completeWalks];
completeWalks = 
 With[{v = Table[Unique[], {dims}]}, #~Join~{v, Table[0, {dims}]} /. 
     FindInstance[Norm[v] == 1 && Norm[v - Last@#] == 1, v, 
      Reals] &] /@ incompleteWalks;

Four resulting walks in 3D:

completeWalks // 
  MapIndexed[{Hue[(First@#2 - 1)/(paths + 1)], 
     Tube@#1} &] // Graphics3D

enter image description here

By setting initial dimension and starting point parameters one can also accomplish 2D random walk (and probably other dimensions too):

completeWalks // 
  MapIndexed[{Hue[(First@#2 - 1)/(paths + 1)], Line@#1} &] // Graphics

enter image description here


Old code:

This, rather messy contraption attempts to drive a random walk process from start point over paths to origin in fixed amount of unit-distance steps. I'm not really convinced; I think it's lazy and spends time near the starting point more than it should, and then hurries to destination when indicators become strong enough it is starting to run out of steps to reach origin. Probability distributions which drive RandomChoice are estimated from sample random walks.

With[
   {steps = 50, paths = 4, start = {20, 0, 0}},
   With[
     (* estimated probability functions for every amount of steps left *)
     {p =
       ParallelTable[
        Function[x, 
           Evaluate@
            PDF[EstimatedDistribution[#, 
              PERTDistribution[{0, n}, a, b],
              (* these are here just to speed up estimation *)
              {{a, 0.3407759964445141` + 0.7140058349745467` Sqrt[n]},
               {b, -5.88256361017025` + 5.436462403959963` Sqrt[n]}}],
            x]] &[
         Norm@Total@# & /@ 
          Map[Normalize, 
           RandomVariate[
            NormalDistribution[0, 1], {10000, n, 3}], {2}]],
         {n, 2, steps - 1}]},
     ParallelTable[
      Last /@ NestList[
        Apply[Function[{level, pt},
          {level - 1, 
           pt + (RandomChoice[
                p[[level - 1]]@Norm[pt + #] & /@ # -> #] &[
              Normalize /@ 
               RandomVariate[
                NormalDistribution[0, 1], {10000, 3}]])}]],
         {steps - 1, start}, steps - 2], {paths}]] //
    (* find a suitable second-to-last point *)
    Map[#~Join~{{x, y, z}, {0, 0, 0}} /. 
       FindInstance[
        Norm[{x, y, z}] == 1 && Norm[{x, y, z} - Last@#] == 1,
        {x, y, z}, Reals] &]] // 
  MapIndexed[{Hue[Mod[GoldenRatio #2, 1]], Tube@#1} &] // Graphics3D

enter image description here

$\endgroup$
  • $\begingroup$ Thank you very much for your help, it# nice. $\endgroup$ – Alexei Boulbitch Mar 25 '15 at 9:21
  • $\begingroup$ @AlexeiBoulbitch Now I've rewritten my implementation to be more understandable in a step-by-step manner. $\endgroup$ – kirma Mar 25 '15 at 14:52
3
$\begingroup$

Use GridGraph as follows:

g = GridGraph[{5, 6}, VertexLabels -> "Name"]

enter image description here

Then find all paths between two vertexes of a given length. For instance, all paths of length 5 between vertexes 7 and 24 are found this way:

myPathList = FindPath[g, 7, 24, {5}, All]

(* { {7, 12, 17, 22, 23, 24}, {7, 12, 17, 18, 23, 24}, {7, 12, 17, 18, 19, 24}, {7, 12, 13, 18, 23, 24}, {7, 12, 13, 18, 19, 24}, {7, 12, 13, 14, 19, 24}, {7, 8, 13, 18, 23, 24}, {7, 8, 13, 18, 19, 24}, {7, 8, 13, 14, 19, 24}, {7, 8, 9, 14, 19, 24} } *)

You will find that if you search for paths that are sufficiently long, then the path may go "past" the end point and then return to it. There turn out to be 10 such paths. Now display them:

Grid[
     Partition[Table[HighlightGraph[g, myPathList[[i]]],
     {i, Length[myPathList]}], 5]
     ]

enter image description here

This simple rendering just shows the vertexes highlighted. You can use GraphHighlightStyle to show the path more clearly.

The same approach generalizes to different length paths, and to paths in three dimensions, as you can explore on your own.

Here's just one of the found paths, highlighted:

HighlightGraph[g, {7 -> 12, 12 -> 17, 17 -> 22, 22 -> 23, 23 -> 24}]

enter image description here

You may need to create the highlighted path this way for proper display:

Table[
 Rule[myPathList[[1, i]], myPathList[[1, i + 1]]],
 {i, 1, Length[myPathList[[1]]] - 1} ]

(* {7 -> 12, 12 -> 17, 17 -> 22, 22 -> 23, 23 -> 24} *)

Here's a 3D example (where the coding is left to the user):

enter image description here

$\endgroup$
  • $\begingroup$ Thank you, this is a nice solution. $\endgroup$ – Alexei Boulbitch Mar 25 '15 at 9:21

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.