10
$\begingroup$

Can Mathematica be used to create diagrams of drift diffusion of the kind shown, including histograms showing the response-time distributions?enter image description here

The distributions capture the time taken by a random walker, starting at 0.5, to hit the "barriers" 1 or 0. They are called reponse-time distributions within psychology because the random walker is assumed to capture evidence accumulation, and a decision is assumed to be made depending on what barrier is hit. Usually the walker has some bias towards the "correct" barrier, and in the shown diagram the blue distribution captures the time taken to make correct decisions, while the red shows the time taken to make the wrong decisions.

$\endgroup$
  • $\begingroup$ Could you explain more about what the histograms represent? The distribution of times to hit 0 and 1? $\endgroup$ – Chris K Nov 9 '19 at 22:33
  • $\begingroup$ @ChrisK I will add more details in the question. $\endgroup$ – user120911 Nov 9 '19 at 22:47
  • $\begingroup$ Some sample data to demo with would be appreciated. $\endgroup$ – C. E. Nov 10 '19 at 9:35
17
$\begingroup$

Here's a similar figure with made-up data:

dist1 = NormalDistribution[0.002, 1/100]; 
dist2 = NormalDistribution[-0.002, 1/10];

randomWalk[] := 
  NestWhileList[# + 0.7 RandomVariate[dist1] + 
     0.3 RandomVariate[dist2] &, 0.5, 0 < # < 1 &];

SeedRandom[0]
{foo, res} = 
  Reap[Do[Sow[Length@#, Clip[Last@#, {0, 1}]] &@randomWalk[], {10000}], {1, 0}];
{{successes}, {failures}} = res;

sdist = SmoothKernelDistribution[successes];
fdist = SmoothKernelDistribution[failures];

SeedRandom[5];
samplewalks = Table[randomWalk[], 4];

Visualization:

yticks = {(*{0.,"0.0000"},*)0.0005, {0.001, "0.0010"}, 0.0015, {0.002, "0.0020"}, 0.0025};
maxtime = 
  Max[Mean[{Max@{successes, failures}, Max@samplewalks}], 10 + Max@samplewalks];
pdfaspectratiofactor = 80;

Column[{
  Plot[
   Length[successes] PDF[sdist, x]/(Length[successes] + Length[failures]),
   {x, 0, maxtime},
   Ticks -> {None, yticks}, Filling -> Axis,
   ImagePadding -> {{35, 12}, {0, 5}}, ImageSize -> Large,
   PlotRange -> {{0, maxtime}, {0, 0.0025}}, 
   AspectRatio -> 0.0025*pdfaspectratiofactor],
  ListLinePlot[
   samplewalks,
   PlotStyle -> (If[Last[#] >= 1, ColorData[97][1], Darker@Red] & /@ samplewalks),
   Frame -> True, FrameTicks -> {{Automatic, None}, {None, None}},
   PlotRange -> {{0, maxtime}, {0, 1}}, PlotRangeClipping -> True,
   ImagePadding -> {{35, 12}, {5, 5}}, ImageSize -> Large, 
   AspectRatio -> 0.4],
  Plot[
   Length[failures] PDF[fdist, x]/(Length[successes] + Length[failures]),
   {x, 0, maxtime},
   ScalingFunctions -> "Reverse",
   FrameTicks -> {{yticks, None}, {Automatic, None}}, Filling -> Axis,
   PlotStyle -> Darker@Red,
   ImagePadding -> {{35, 12}, {15, 0}}, ImageSize -> Large, 
   Frame -> True,
   PlotRange -> {{0, maxtime}, {0, 0.0011}}, 
   AspectRatio -> 0.0011*pdfaspectratiofactor]
  }, Center, 0]

enter image description here

| improve this answer | |
$\endgroup$

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.