2D random walk within a bounded area

Question

I want to simulate a random walk in two dimensions within a bounded area, such as a square or a circle. I am thinking of using an If statement to define a boundary. Is there a better way to define a bounded region?

Answer 1

To answer your question: I don't think it's a bad or good idea to use If. It depends on how you do it. To demonstrate I'll use If combined very powerfully with Mathematica 10's ability to tell if a point is inside a specified region or not.

step[position_, region_] := Module[{randomStep},
  randomStep = RandomChoice[{{-1, 0}, {1, 0}, {0, -1}, {0, 1}}];
  If[
   Element[position + randomStep, region],
   position + randomStep,
   position
   ]
  ]

randomWalk[region_, n_] := NestList[
  step[#, region] &,
  {0, 0},
  n
  ]

visualizeWalk[region_, n_] := Graphics[{
   White, region,
   Black, Line[randomWalk[region, n]]
   }, Background -> Black]

visualizeWalk[Disk[{0, 0}, 30], 10000]

This version of visualizeWalk accepts arbitrary regions:

visualizeWalk[graphics_, region_, n_] := Graphics[{
   White, graphics,
   Black, Line[randomWalk[region, n]]
   }, Background -> Black]

region = {
   Disk[{-25, 0}, 30, {-Pi/2, Pi/2}],
   Disk[{25, 0}, 30]
   };
visualizeWalk[region, RegionUnion[region], 10000]

visualizeWalk[
 {Disk[{-17.5, 0}, 30], Darker@Gray, Disk[{-17.5, 0}, 15]},
 RegionDifference[Disk[{-17.5, 0}, 30], Disk[{-17.5, 0}, 15]]
 , 10000]

Answer 2

I suggest using Mod - a natural thing for looped boundary conditions on a torus.

Finite torus surface area is your bounded region.

2D random walk generally is simple:

walk = Accumulate[RandomReal[{-.1, .1}, {100, 2}]];
Graphics[Line[walk], Frame -> True]

Confinement to square region {{0,1},{0,1}} would be simple in principle with Mod[walk,1] (periodic boundary conditions) but visualizing will be hard:

Graphics[Line[Mod[walk, 1]], Frame -> True]

So I think logical, for periodic boundary conditions, to place it on a torus ( with arbitrary radiuses ):

map[φ_, θ_] = CoordinateTransformData["Toroidal" -> "Cartesian", 
              "Mapping", {r, θ, φ}] /. {\[FormalA] -> 1, r -> 2 Log[2]}

walk = Accumulate[RandomReal[{-.1, .1}, {10^4, 2}]];
Graphics3D[{Opacity[.5], Line[map @@@ walk]}, SphericalRegion -> True]

Answer 3

Here's my implement of a random walk within a circle using If and FoldList. Please see @Pickett's answer for more thorough implementation for arbitrary regions. Code updated to flesh out behavior near edge of region (if a step becomes out of bound, the current position will randomly look for the other step types that would stay in the region). I also added some formatting to the display to indicate the positions and indices of the point and when it's about to hit the edge of the region (highlighted in red).

Clear[randomWalk]
randomWalk[steps_Integer, start_, region_] /; 
  start ∈ region := 
 DynamicModule[{stepTypes, stepList, alternativeStep, stepChoice, 
   positions, edgePositions, pointPrimitives, text},
(* 4 types of steps: {{0,1},{1,0},{0,-1},{-1,0}}: up, down, left, 
  right *)
  stepTypes = Flatten[Permutations[#, {2}] & /@ {{0, 1}, {0, -1}}, 1];
(* Generate list of random steps *)
  stepList = RandomChoice[stepTypes, steps];
(* If a step were to result in position outside of circle, 
  the step is not taken, 
  an alternative step type is chosen randomly from the remaining 

types; also, 
  the position near the edge woule also be Sowed to be Reaped later. 
  Otherwise, the step is taken )
  alternativeStep[currentPosition_, nextStep_] := 
   RandomChoice[
    Select[Complement[
      stepTypes, {nextStep}], (currentPosition + # ∈ 
        region &)]];
  stepChoice[currentPosition_, nextStep_, nearEdgePosition_] :=
   If[currentPosition + nextStep ∈ region,
    currentPosition + nextStep,
    (Sow[nearEdgePosition];
     ( else *)
     currentPosition + alternativeStep[currentPosition, nextStep])];
(* List of all positions and near edge positions *)
  {positions, edgePositions} = 
   FoldList[stepChoice[#1, Sequence @@ #2] &, start, 
     MapIndexed[List, stepList]] // Reap;
(* Display *)
  pointPrimitives[
    n_Integer] := {If[MemberQ[Flatten@edgePositions, n], Red, Black], 
    Point[positions[[n]]]};
  text[n_Integer] := 
   Text[Style[Row@{n, ": ", positions[[n]]}, 
     If[MemberQ[Flatten@edgePositions, n], Red, Black], Bold, 
     15], {Right, Top}, {1., 1.}];
  Manipulate[
   Graphics[{Gray, region, AbsolutePointSize[5], White, 
     Point[positions], pointPrimitives[i], text[i]}, Frame -> True, 
    ImagePadding -> 25], {i, 1, Length[positions], 1}]
  ]
randomWalk[1000, {4, 4}, Disk[{0, 0}, 7]]

---

You can export this as an animation by creating a list of frames e.g. by using Table instead of Manipulate. Don't forget to change DynamicModule to Module or you'll get an image of a table of frames instead of an animation using Export["randomwalk.gif", frames]. This is because even though it will look like a list of frames in the notebook, DynamicModule will still wrap that list. All credits to @Pickett for this tip. Warning: gif might be slow to load.

---

Code can be easily adapted to 3D

Clear[randomWalk3D]
randomWalk3D[steps_Integer, start_, region_] /; 
  start ∈ region := 
 DynamicModule[{stepTypes, stepList, alternativeStep, stepChoice, 
   positions, edgePositions, pointPrimitives, text},
(* 6 types of steps for 3D *)
  stepTypes = 
   Flatten[Permutations[#, {3}] & /@ {{0, 0, 1}, {0, 0, -1}}, 1];
(* Generate list of random steps *)
  stepList = RandomChoice[stepTypes, steps];
(* If a step were to result in position outside of circle, 
  the step is not taken, 
  an alternative step type is chosen randomly from the remaining 

types; also, 
  the position near the edge woule also be Sowed to be Reaped later. 
  Otherwise, the step is taken )
  alternativeStep[currentPosition_, nextStep_] := 
   RandomChoice[
    Select[Complement[
      stepTypes, {nextStep}], (currentPosition + # ∈ 
        region &)]];
  stepChoice[currentPosition_, nextStep_, nearEdgePosition_] :=
   If[currentPosition + nextStep ∈ region,
    currentPosition + nextStep,
    (Sow[nearEdgePosition];
     ( else *)
     currentPosition + alternativeStep[currentPosition, nextStep])];
(* List of all positions and near edge positions *)
  {positions, edgePositions} = 
   FoldList[stepChoice[#1, Sequence @@ #2] &, start, 
     MapIndexed[List, stepList]] // Reap;
(* Display *)
  pointPrimitives[
    n_Integer] := {If[MemberQ[Flatten@edgePositions, n], Red, Black], 
    Point[positions[[n]]]};
  text[n_Integer] := 
   Epilog -> 
    Inset[Style[Row@{n, ": ", positions[[n]]}, 
      If[MemberQ[Flatten@edgePositions, n], Red, Black], Bold, 
      15], {Right, Top}, {Right, Top}];
Manipulate[
   Graphics3D[{Opacity[0.5, Gray], region, AbsolutePointSize[5], 
     White, Point[positions], pointPrimitives[i]}, text[i], 
    ImagePadding -> 25, Lighting -> {{"Ambient", Gray}}], {i, 1, 
    Length[positions], 1}]
  ]
randomWalk3D[1000, {4, 4, 4}, Ball[{0, 0, 0}, 7]]

Answer 4

You can use RegionWithin in Mathematica $11.1$

pol = Entity["Country", "Georgia"]["Polygon"] /. GeoPosition -> Identity;

Ω= Polygon[Map[Reverse, pol[[1]][[1]]]];
start = Reverse@CountryData["Georgia", "CenterCoordinates"];

points[pt_, r_, region_] :=
Block[{npt = RandomPoint[Sphere[pt, r]]},
While[! RegionWithin[region, Line[{pt, npt}]],
npt = RandomPoint[Sphere[pt, r]]]; npt]

path = NestList[points[#, 0.1, Ω] &, start, 1200];

Graphics[{{Ω}, {Blue, Thickness[0.0018], Line[path]}, {Red, PointSize[Medium], 
Point[Last[path]]},{Red, PointSize[Large], Point[start]}}, ImageSize -> 600]

Answer 5

I chose the WienerProcess as the underlying random process, as this will simulate a Brownian motion.

Until Boundary Hit

Module[{rd = Transpose @ RandomFunction[WienerProcess[], {0, 1000, .01}, 2]["States"], length},
 length = LengthWhile[rd, # ∈ Rectangle[{-2, -2}, {+2, +2}] &];
 ListPlot[rd[[;; length]], Joined -> True, Mesh -> All, PlotRange -> {{-2.5, 2.5}, {-2.5, 2.5}}, 
  Epilog -> {EdgeForm[Thick], White, Opacity[0], Rectangle[{-2, -2}, {+2, +2}]}, ImageSize -> Large]
 ]

Other Direction Inside the Boundary

First the single moves as definded by a WienerProcess:

randomMove = Transpose[Differences /@ 
               RandomFunction[WienerProcess[], {0, 100, .1}, 2]["States"]];

These are

Length@randomMove

1000

steps.

We'll start at

start = {0., 0.};

and define the boundary as a square

box2D = Rectangle[{-2, -2}, {+2, +2}];

Now the random walk inside this box is created with:

last = start;
walk = First@Last@Reap@Do[
  new = last + randomMove[[i]];
  If[new ∈ box2D,
   last = new;
   Sow@new, Null],
  {i, Length@randomMove}
  ];
randomInTheBox = Prepend[walk, start];

In my last run these where

Length@randomInTheBox

882

points.

A plot of the result:

ListPlot[randomInTheBox, Joined -> True, Mesh -> All, MeshStyle -> Black, AspectRatio -> 1, 
  Epilog -> {EdgeForm[{Thick, Red}], White, Opacity[0], 
             Rectangle[{-2, -2}, {+2, +2}]}, ImageSize -> Large]

The walk can be traced with

Manipulate[ListPlot[randomInTheBox, Joined -> True, Mesh -> All, 
  MeshStyle -> Black, AspectRatio -> 1, 
  Epilog -> {PointSize[Medium], Red, Point[randomInTheBox[[p]]], 
             EdgeForm[{Thick, Red}], Opacity[0], box2D}],
 {p, 1, Length@randomInTheBox, 1}]

---

If you need to run this simulation multiple times, it is beneficial to put these steps together, e.g.

randomInTheBox = Prepend[
  Block[{randomMove = Transpose[Differences /@ 
         RandomFunction[WienerProcess[], {0, 100, .1}, 2]["States"]], 
         length, last, new},
    length = Length@randomMove;
    last = start;
    First@Last@Reap@Do[
      new = last + randomMove[[i]];
      If[new \[Element] box2D,
        last = new;
        Sow@new, Null],
      {i, Length@randomMove}]
  ],
  start];

---

The random process can easily be replaced by an other one and a different definition for the bounding area be chosen. Furthermore an extension of this approach to 3D is straight forward.

Answer 6

Walking infinitely in a random and acceptable direction within a rectangle on button click, stepSize = 1.

DynamicModule[{newDir, walk = {{0, 0}}, oldPos, newPos = {0, 0}, 
  acceptQ = -20 <= #[[1]] <= +20 && -10 <= #[[2]] <= +10 &},
 {
   Button["Next Step", oldPos = newPos; 
    newPos = {\[Infinity], \[Infinity]}; 
    While[Not@acceptQ@newPos, newDir = RandomReal@{-Pi, +Pi}; 
     newPos = oldPos + {Cos@newDir, Sin@newDir}];
    walk = Append[walk, newPos]],
   Dynamic@
    Graphics[{White, Rectangle[{-20, -10}, {20, 10}], Gray, Line@walk,
       Point@walk, Red, Point@newPos}, ImageSize -> 500, Frame -> True]
   } // Column]