Improved Data Analysis of Millikan Experiment Using Mathematica

David Smrcka, Jan Riha
Department of Experimental Physics, Faculty of Science, Palacky University in Olomouc

Join the Conversation #WolframTechConf

About us

GeoGraphics[{LinguisticAssistant,EdgeForm[Gray],Opacity[1],FaceForm[{Black,Opacity[1]}],GeoStyling[Orange,Opacity[.8]],Polygon[LinguisticAssistant]},ImageSize->Large]

GeoGraphics[{GeoMarker[LinguisticAssistant,"Scale"->Scaled[0.1]],FaceForm[None],EdgeForm[Black],Polygon[(Entity["Czech Republic", Entity["Country","CzechRepublic"], "Entity[\"Country\", \"CzechRepublic\"]", "country"])]}]

Faculty of Science, Palacky University in Olomouc

({{, }})

Millikan experiment

Oil drop experiment performed by Robert A. Millikan and Harvey Fletcher in 1909 to measure the elementary electric charge.

Elementary charge : 1.602176634*(10^(-19)) C

Simple idea: Charged oil droplets subjected to an electric field and to gravity between the plates of a capacitor are accelerated by application
of a voltage.

Animate[scena1[[m]],{m,1,120,1},DefaultDuration->12,AnimationRunning->False]

Millikan experiment

Oil drop experiment performed by Robert A. Millikan and Harvey Fletcher in 1909 to measure the elementary electric charge.

Simple idea: Charged oil droplets subjected to an electric field and to gravity between the plates of a capacitor are accelerated by application
of a voltage.

Animate[scena2[[m]],{m,1,80,1},DefaultDuration->8,AnimationRunning->False]

Charge of oil droplet:

Q=(9/2)πd (Sqrt[((η^3)/(g((Subscript[ρ, 1])-(Subscript[ρ, 2]))))])((((Subscript[v, 1])+(Subscript[v, 2]))/U))(Sqrt[(Subscript[v, 1])-(Subscript[v, 2])])

Radius of oil droplet:

r=(3/2)(Sqrt[((η((Subscript[v, 1])-(Subscript[v, 2])))/(g((Subscript[ρ, 1])-(Subscript[ρ, 2]))))])

Velocity falling in the electric field (Subscript[v, 1]), velocity rising in the electric field (Subscript[v, 2]), capacitor voltage U, capacitor interelectrode distance d, density of the silicone oil (Subscript[ρ, 1]), density of air (Subscript[ρ, 2]), viscosity of air η, gravitational acceleration g.

Experimental setup

({{, , }})

Image processing of data - droplets coordinates extraction

Video footage is split into separate images frame by frame. Webcam can make 30 frames per second.

Using ffmpeg software we obtain all recorded frames with timestamps.

Example of a frame containing observed oil droplets.

Used image processing functions: Binarize, EdgeDetect and ComponentMeasurements.

Step 1 - remove length scale

Remove length scale from image to observe only droplets. ImageSubtract and Binarize.

Blank slide

blank=;

blank=ImageSubtract[blank,Graphics[{Black,Disk[{444,385},360]},PlotRange->{{0,960},{0,720}}]]

Frame with oil droplets

frame=;

frame=ImageSubtract[frame,Graphics[{Black,Disk[{444,385},325]},PlotRange->{{0,960},{0,720}}]]

Results from subtracting both images

subtracted=ImageSubtract[frame,blank]

For easier processing, colors are binarized.

binar=Binarize[subtracted,0.1]

Changing threshold value of Binarize allows for adjustments during analysis.

Manipulate[ImageResize[Binarize[subtracted,n],800],{n,0.001,1}]

Step 2 - locate droplets

Locate droplets. EdgeDetect.

edges=EdgeDetect[binar]

Find objects of circular shape and extract their center coordinates.

components=ComponentMeasurements[edges,{"Centroid","EquivalentDiskRadius"}]

Step 3 - visualize

Highlighting located droplets.

Show[
frame,
Graphics[{Red,Circle[#,5]&/@components[[All,2,1]]}]
]

Image processing of data - working tool

Previous functions combined together to create interactive tool for analysis.

Using Nearest[] function we are able to follow the path of droplet between frames without need to select its position on each frame.

DynamicModule[{frameX,edge,closest,nearestDistance=0,prevDroplet={0,0},p=First@vyrez,enablePlus=True,enableMinus=True,
autorun=False,measure=False,arr={},n=1,bb=0.18,showbb,closestLimit=10},
showbb=bb;
(* FUNKCE *)
getDroplets[]:=(
frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradnice kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]];
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
prevDroplet=p
);

(* INICIALIZACE *)
arr=Table[{logFile[[i]],{0,0}},{i,Length[frames]}];
(* Vygenerovani obrazku a lokace kapek *)
frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradnice kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]];
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
prevDroplet=p;

(* GUI *)
Column[{
(* OVLADANI*)
Grid[{
{InputField[Dynamic[n],ImageSize->60],
Row[{
(* go to *)
Button["go to",If[n>0&&n≤Length[frames],
enablePlus=True;enableMinus=True;
frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradince kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]];
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
prevDroplet=p
],
ImageSize->60
],
Spacer[5],

(* next frame *)
Button[Style["-",12,Bold],If[(n-1)≥1,n=n-1;enablePlus=True;
frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradince kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]];
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
prevDroplet=p,
(* false *)
enableMinus=False
],
Enabled->Dynamic@enableMinus,
ImageSize->30
],

(* previous frame *)
Button[Style["+",12,Bold],If[(n+1)≤Length[frames],n=n+1;enableMinus=True;
frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradince kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]];
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
prevDroplet=p,
(* false *)
enablePlus=False;
],
Enabled->Dynamic@enablePlus,
ImageSize->30
],
Spacer[5]
}]
},
{
InputField[Dynamic[showbb],Enabled->False,ImageSize->60],
Slider[Dynamic[bb,{(showbb=#;bb=#;frameX=ImageSubtract[frames[[n]],Graphics[{Black,Disk[First@vyrez,Last@vyrez]},PlotRange->{{0,960},{0,720}}]];
edge=ComponentMeasurements[Binarize[ImageSubtract[frameX,blankX],bb]//EdgeDetect,{"Centroid","EquivalentDiskRadius"}];
(* vystupem jsou souradince kapek *)
edge=edge[[All,2,1]];
If[Length[edge]<2,AppendTo[edge,{0,0}];AppendTo[edge,vyrez[[1]]]])&}],{0.01,1},Appearance->"Open"]
},
{Row[{"measure ",Checkbox[Dynamic[measure]]}]},
{Button["print",Print[arr]],Dynamic[p]}
}],

(* VYSTUP *)
LocatorPane[
Dynamic[p],
Dynamic@Show[
prevDroplet=p;
If[autorun,
(* Automaticke prochazeni *)
closest=First@Nearest[edge,prevDroplet];
arr[[n,2]]=closest,
(* Manualni prochazeni *)
closest=First@Nearest[edge,p];
p=closest;
If[measure,arr[[n,2]]=p]
];
frameX,
If[arr[[n,2]]=={0,0},
Graphics[{Red,Circle[#,5]&/@edge,Opacity[0.5],Orange,Disk[closest,5]}],
Graphics[{Red,Circle[#,5]&/@edge,Opacity[0.5],Orange,Disk[arr[[n,2]],5]}]
]
],
Appearance->None
]
}](*,
Initialization:>{arr=Table[{logFile[[i]],{0,0}},{i,Length[frames]}]}*)]

Image processing of data - from trajectory to velocity

Plotting droplet coordinates from all frames representing trajectory per time.

DynamicModule[{p={0,0},zprava="blank",zprava2="blank",bod,pS={0,0},pK={0,0},array,fited=False,fit,plot=False},
array=trajectory;
Column[{
(*buttons*)
Row[{
Button[Style["BEGIN",Blue,Bold],pS=p;plot=False,ImageSize->150],
Button[Style["END",RGBColor[0.3,.8,0.3],Bold],pK=p;plot=False,ImageSize->150],
Button[Style["FIT",Bold],zprava={pS,pK};fit=extractData[array,pS[[1]],pK[[1]]];zprava=fit["BestFit"];
zprava2=fit["RSquared"];plot=True,ImageSize->150]
}],
(*image*)
LocatorPane[
Dynamic[p],
Dynamic@Show[
ListPlot[array,ImageSize->Large,AxesLabel->{"TIME","DISTANCE"},AxesStyle->Directive[Black,14]],
Graphics[{
Gray,Line[{{First@p,Last@p-400},{First@p,Last@p+400}}],
Blue,Line[{{First@pS,Last@pS-400},{First@pS,Last@pS+400}}],
RGBColor[0.3,.8,0.3],Line[{{First@pK,Last@pK-400},{First@pK,Last@pK+400}}]
}],
If[plot,Plot[fit["BestFit"],{x,pS[[1]]-0.5,pK[[1]]+0.5},PlotStyle->{Red,Thick}],Graphics[Point[{0,0}]]]
],
Appearance->None
],
(*output*)
Grid[{
{"fitted function ",Dynamic[zprava]},
{"(R^2)",Dynamic[zprava2]}
}]
}]
]

Results

WIth Mathematica:
	Mean value: 1.5968648889677421`*^-19 C
	Standard deviation: 1.5860905326925423`*^-20 C

Results

({{, }})

WIth Mathematica:
	Mean value: 1.5968648889677421`*^-19 C
	Standard deviation: 1.5860905326925423`*^-20 C

Without Mathematica
	Mean value: 1.6216717261904763`*^-19
	Standard deviation: 1.35081990804819`*^-20

Thank you for your attention.

Initialize

trajectory={{0.067`,{325.1333333333333`,155.4`}},{0.133`,{325.1333333333333`,155.4`}},{0.2`,{325.08620689655174`,153.98275862068965`}},{0.267`,{328.5`,152.`}},{0.333`,{328.5`,151.5`}},{0.4`,{327.72222222222223`,147.27777777777777`}},{0.467`,{327.88461538461536`,146.1153846153846`}},{0.533`,{328.22727272727275`,146.13636363636363`}},{0.6`,{328.5`,144.375`}},{0.667`,{329.5`,142.`}},{0.733`,{329.5`,139.`}},{0.8`,{329.375`,138.5`}},{0.867`,{329.5`,138.625`}},{0.933`,{329.5`,141.5`}},{1.`,{329.1923076923077`,143.96153846153845`}},{1.067`,{330.7`,145.9`}},{1.133`,{331.`,150.`}},{1.2`,{331.1`,152.3`}},{1.267`,{330.5`,154.5`}},{1.333`,{331.`,158.4`}},{1.4`,{331.6875`,161.5`}},{1.467`,{332.`,164.5`}},{1.533`,{332.1666666666667`,166.83333333333334`}},{1.6`,{332.1666666666667`,169.83333333333334`}},{1.667`,{332.27777777777777`,172.27777777777777`}},{1.733`,{331.5`,172.5`}},{1.8`,{332.`,172.5`}},{1.867`,{332.375`,171.5`}},{1.933`,{332.5`,170.5`}},{2.`,{332.5`,167.5`}},{2.067`,{331.95454545454544`,166.77272727272728`}},{2.133`,{332.`,166.`}},{2.2`,{332.`,164.5`}},{2.267`,{332.5`,163.5`}},{2.333`,{332.625`,161.375`}},{2.4`,{333.6`,160.9`}},{2.467`,{334.5`,159.`}},{2.533`,{335.`,158.`}},{2.6`,{336.1`,155.4`}},{2.667`,{337.`,154.`}},{2.733`,{338.375`,152.5`}},{2.8`,{338.625`,150.625`}},{2.867`,{339.`,148.5`}},{2.933`,{339.5`,147.5`}},{3.`,{340.3`,145.3`}},{3.067`,{341.5`,144.`}},{3.133`,{342.1`,142.4`}},{3.2`,{342.22727272727275`,142.04545454545453`}},{3.267`,{343.`,145.5`}},{3.333`,{343.`,149.`}},{3.4`,{343.625`,151.5`}},{3.467`,{344.`,153.5`}},{3.533`,{344.22727272727275`,156.86363636363637`}},{3.6`,{344.5`,160.`}},{3.667`,{345.1`,163.4`}},{3.733`,{345.5`,166.`}},{3.8`,{345.5`,169.`}},{3.867`,{345.5`,171.5`}},{3.933`,{345.5`,175.`}},{4.`,{345.9`,177.6`}},{4.067`,{347.1`,180.4`}},{4.133`,{347.9`,182.6`}},{4.2`,{348.5`,184.`}},{4.267`,{348.5`,184.`}},{4.333`,{348.5`,182.5`}},{4.4`,{349.6`,181.1`}},{4.467`,{349.6`,179.9`}},{4.533`,{350.1`,177.6`}},{4.6`,{350.`,176.`}},{4.667`,{350.375`,174.5`}},{4.733`,{350.`,172.5`}},{4.8`,{350.`,171.`}},{4.867`,{350.9`,169.6`}},{4.933`,{351.`,167.`}},{5.`,{351.5`,166.`}},{5.067`,{351.5`,164.625`}},{5.133`,{351.625`,163.5`}},{5.2`,{351.9`,161.4`}},{5.267`,{353.1`,158.4`}},{5.333`,{354.`,156.5`}},{5.4`,{354.625`,153.625`}},{5.467`,{354.625`,152.375`}},{5.533`,{354.6`,151.1`}},{5.6`,{355.`,152.5`}},{5.667`,{355.22727272727275`,155.04545454545453`}},{5.733`,{355.5`,157.`}},{5.8`,{355.625`,159.5`}},{5.867`,{356.1`,161.4`}},{5.933`,{356.1`,164.4`}},{6.`,{356.`,167.`}},{6.067`,{356.`,169.5`}},{6.133`,{356.`,172.5`}},{6.2`,{356.5`,174.5`}},{6.267`,{356.1`,177.4`}},{6.333`,{356.5`,181.5`}},{6.4`,{357.`,184.`}},{6.467`,{357.5`,187.`}},{6.533`,{357.6`,190.`}},{6.6`,{357.8333333333333`,192.16666666666666`}},{6.667`,{359.4`,196.1`}},{6.733`,{359.9`,198.6`}},{6.8`,{360.375`,198.625`}},{6.867`,{360.5`,196.625`}},{6.933`,{360.4`,195.1`}},{7.`,{360.625`,194.5`}},{7.067`,{360.8333333333333`,191.83333333333334`}},{7.133`,{361.`,190.5`}},{7.2`,{361.`,189.`}},{7.267`,{361.5`,188.5`}},{7.333`,{360.5`,185.5`}},{7.4`,{361.5`,184.5`}},{7.467`,{360.5`,182.`}},{7.533`,{361.`,181.5`}},{7.6`,{360.5`,179.`}},{7.667`,{360.5`,177.`}},{7.733`,{360.5`,175.5`}},{7.8`,{360.5`,178.5`}},{7.867`,{362.04545454545456`,183.22727272727272`}},{7.933`,{362.375`,185.375`}},{8.`,{362.`,188.5`}},{8.067`,{362.6111111111111`,191.72222222222223`}},{8.133`,{363.5`,195.9`}},{8.2`,{364.375`,198.625`}},{8.267`,{365.375`,201.375`}},{8.333`,{365.8636363636364`,203.13636363636363`}},{8.4`,{366.375`,205.375`}},{8.467`,{366.1666666666667`,209.16666666666666`}},{8.533`,{366.6111111111111`,210.72222222222223`}},{8.6`,{367.1666666666667`,209.33333333333334`}},{8.667`,{366.77272727272725`,208.04545454545453`}},{8.733`,{366.27777777777777`,205.72222222222223`}},{8.8`,{366.8333333333333`,204.08333333333334`}},{8.867`,{367.`,203.`}},{8.933`,{367.9`,201.7`}},{9.`,{367.9`,200.6`}},{9.067`,{369.375`,198.5`}},{9.133`,{369.`,196.5`}},{9.2`,{369.4`,195.1`}},{9.267`,{370.5`,192.`}},{9.333`,{370.9166666666667`,191.16666666666666`}},{9.4`,{371.375`,190.375`}},{9.467`,{371.7`,188.7`}},{9.533`,{372.5`,186.5`}},{9.6`,{373.1`,188.4`}},{9.667`,{373.5`,190.5`}},{9.733`,{374.`,191.5`}},{9.8`,{374.5`,196.`}},{9.867`,{376.4`,198.1`}},{9.933`,{377.4`,201.1`}},{10.`,{378.`,204.5`}},{10.067`,{379.5`,207.5`}},{10.133`,{380.27777777777777`,210.27777777777777`}},{10.2`,{381.`,213.5`}},{10.267`,{381.5`,216.27777777777777`}},{10.333`,{382.5`,219.`}},{10.4`,{383.375`,222.5`}},{10.467`,{384.1`,224.3`}},{10.533`,{384.5`,228.`}},{10.6`,{384.4`,230.`}},{10.667`,{384.5`,230.5`}},{10.733`,{386.04545454545456`,228.77272727272728`}},{10.8`,{386.8333333333333`,226.83333333333334`}},{10.867`,{386.95454545454544`,225.22727272727272`}},{10.933`,{387.375`,222.375`}},{11.`,{387.9`,220.3`}}};

trajectory=Transpose[{trajectory[[All,1]],trajectory[[All,2,2]]}];

extractData[listD_,start_,stop_]:=Module[{near1,near2,pos1,pos2,fit},
near1=First@Nearest[listD[[All,1]],start];
near2=First@Nearest[listD[[All,1]],stop];
pos1=Position[listD[[All,1]],near1][[1,1]];
pos2=Position[listD[[All,1]],near2][[1,1]];
fit=LinearModelFit[listD[[pos1;;pos2]],{x},x]
]

blankX=;

vyrez={{444,385},360};

frames={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};

logFile={0.067`,0.133`,0.2`,0.267`,0.333`,0.4`,0.467`,0.533`,0.6`,0.667`,0.733`,0.8`,0.867`,0.933`,1.`,1.067`,1.133`,1.2`,1.267`,1.333`,1.4`,1.467`,1.533`,1.6`,1.667`,1.733`,1.8`,1.867`,1.933`,2.`,2.067`,2.133`,2.2`,2.267`,2.333`,2.4`,2.467`,2.533`,2.6`,2.667`,2.733`,2.8`,2.867`,2.933`,3.`,3.067`,3.133`,3.2`,3.267`,3.333`,3.4`,3.467`,3.533`,3.6`,3.667`,3.733`,3.8`,3.867`,3.933`,4.`,4.067`,4.133`,4.2`,4.267`,4.333`,4.4`,4.467`,4.533`,4.6`,4.667`,4.733`,4.8`,4.867`,4.933`,5.`};

scena1=Table[Import[FileNameJoin[{NotebookDirectory[],"obrazky","scena1-"<>ToString[m]<>".png"}]],{m,120}]

scena1={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};

scena2=Table[Import[FileNameJoin[{NotebookDirectory[],"obrazky","scena2-"<>ToString[m]<>".png"}]],{m,100}]

scena2={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};