Underrepresented groups in mathematics.

The idea of this document is to compare the demographics of “highly prepared” entering math students with the demographics of the math major in order to identify underrepresented groups in the major.

To define mathematically prepared students, we’ll use those who got scores in various ranges on the SAT (we’re using 2013 data here), downloaded from the College Board (SAT-Percentile-Ranks.pdf).

MalePR = {{400,13},{450,25},{500,39},{550,55},{600,69},{650,81},{700,90},{750,96},{800,99}};
FemalePR = {{400,18},{450,33},{500,50},{550,67},{600,80},{650,89},{700,95},{750,98},{800,99}};
BlackPR = {{400,37},{450,59},{500,76},{550,88},{600,94},{650,98},{700,99},{750,99.5},{800,99.75}};
AsianPR = {{400,6},{450,13},{500,22},{550,34},{600,47},{650,60},{700,75},{750,87},{800,96}};
MexicanPR = {{400,24},{450,44},{500,64},{550,80},{600,90},{650,96},{700,99},{750,99.5},{800,99.75}};
PuertoricanPR = {{400,30},{450,49},{500,67},{550,82},{600,91},{650,96},{700,99},{750,99.5},{800,99.75}};
OtherLatinoPR = {{400,27},{450,46},{500,64},{550,79},{600,89},{650,95},{700,98},{750,99},{800,99.5}};
WhitePR = {{400,8},{450,20},{500,36},{550,55},{600,72},{650,84},{700,94},{750,98},{800,99.5}};

MaleN = 776092; 
FemaleN = 883995;
BlackN =210151;
AsianN = 196030;
MexicanN = 114506;
PuertoricanN = 27871;
OtherLatinoN = 141884;
WhiteN = 834933;

We now can compute the number of students in each demographic category with scores above a certain threshold:

TotalStudents[PR_,N_] := {#[[1]],Round[((100 - #[[2]])/100) N]} &/@ PR;

MaleTotals = TotalStudents[MalePR,MaleN];
FemaleTotals = TotalStudents[FemalePR,FemaleN];
BlackTotals = TotalStudents[BlackPR,BlackN];
AsianTotals = TotalStudents[AsianPR,AsianN];
MexicanTotals = TotalStudents[MexicanPR,MexicanN];
PuertoricanTotals = TotalStudents[PuertoricanPR,PuertoricanN];
OtherLatinoTotals = TotalStudents[OtherLatinoPR,OtherLatinoN];
WhiteTotals = TotalStudents[WhitePR,WhiteN];

We can now combine these totals to get an “idealized” math major at various thresholds:

MFCombined = {#[[1,1]],{"Male",#[[1,2]]},{"Female",#[[2,2]]}} & /@Transpose[{MaleTotals,FemaleTotals}]

GenderPie[cutoff_] := Module[{data,total},
data = Select[MFCombined,#[[1]] == cutoff &][[1]];
total = data[[2,2]] + data[[3,2]];

PieChart[{data[[2,2]],data[[3,2]]},ChartLabels->{"Male "<> ToString[Round[100data[[2,2]]/total]] <> "%","Female " <> ToString[Round[100data[[3,2]]/total]] <> "%"},PlotLabel->"Distribution of Gender in Students with Math Score > "<>ToString[data[[1]]]]
];

GenderPie[550]

Now we want to compare this to the percentage of students in the math major. The best data it seems we can get is from the NSF Science and Engineering indicators 2014, which show data for Bachelor’s degrees awarded in 2011. Of course, the 3 year lag is a problem, as is the problem is that we’re comparing students now entering with students previously graduating. 

But we’re not looking for trends here, just a rough estimate of “the current picture”. We get:

18,021 Math degrees in 2011 (both genders)
10,276 degrees awarded to males
7,745 degrees awarded to females

Range[10][[{1,5,7}]]

MathMajorsGender = {{"Math Majors 2011",{"Male",10276},{"Female",7745}}};
USPopGender = {{"U.S. Population",{"Male",49.1},{"Female",50.9}}};
CBSGender = {{"College Bound Seniors",{"Male",MaleN},{"Female",FemaleN}}};
GenderCombinedWithMath = Join[MFCombined[[{1,3,5}]],Join[MathMajorsGender,CBSGender]]

N[CBSGender[[1,3,2]]/(CBSGender[[1,3,2]] + CBSGender[[1,2,2]])]

N[MathMajorsGender[[1,3,2]]/(MathMajorsGender[[1,3,2]] + MathMajorsGender[[1,2,2]])]

GenderSplit = BarChart[
{#[[2,2]],#[[3,2]]}& /@ GenderCombinedWithMath,ChartLayout->"Percentile",ChartLabels->{{"n=400","n=500","n=600","Math Majors","CBS Pop","U.S. Pop"},{"Male","Female"}},BarSpacing->{None,0.2},ImageSize->Medium,PlotLabel->"Distribution of Gender\n Students with Math SAT > n, Math Majors, College Bound Seniors"]

Export[NotebookDirectory[]<>"GenderDistribution.pdf",GenderSplit]

Export[NotebookDirectory[]<>"GenderDistribution.png",GenderSplit,ImageSize->Large]

One could argue that stereotype threat is unfairly depressing the scores of women on the math SAT. So let’s correct for this by awarding an additional 50 points to women, comparing women >= 450, men >= 500, math majors, and the CBS population.

GenderCorrectedWithMath = Join[MathMajorsGender,{{"500/450",MFCombined[[3,2]],MFCombined[[2,3]]}},CBSGender]

GenderCorrectedWithMath2 = Join[{{"500/450",MFCombined[[5,2]],MFCombined[[4,3]]}},MathMajorsGender,CBSGender]

GenderSplitCorrected = BarChart[
{#[[2,2]],#[[3,2]]}& /@ GenderCorrectedWithMath,ChartLayout->"Percentile",ChartLabels->{{"Math Majors","n=450(F)/500(M)","CBS Pop","U.S. Pop"},{"Male","Female"}},BarSpacing->{None,0.2},ImageSize->Medium,PlotLabel->"Distribution of Gender\n Math Majors, Math SAT > n, College Bound Seniors"]

Export[NotebookDirectory[]<>"CorrectedGenderDistribution.png",GenderSplitCorrected,ImageSize->Large]

RacialCombined = {#[[1,1]],{"Black",#[[1,2]]},{"Asian",#[[2,2]]},{"All Latino",#[[3,2]] + #[[4,2]] + #[[5,2]]},{"White",#[[6,2]]}} & /@
Transpose[{BlackTotals,AsianTotals,MexicanTotals,PuertoricanTotals,OtherLatinoTotals,WhiteTotals}]

RacialPie[cutoff_] := Module[{data,total},
data = Select[RacialCombined,#[[1]] == cutoff &][[1]];
total = data[[2,2]] + data[[3,2]] + data[[4,2]] + data[[5,2]];

PieChart[{data[[2,2]],data[[3,2]],data[[4,2]],data[[5,2]]},ChartLabels->{"Black "<> ToString[Round[100data[[2,2]]/total]] <> "%","Asian " <> ToString[Round[100data[[3,2]]/total]] <> "%",
  "Hispanic/Latino " <> ToString[Round[100data[[4,2]]/total]] <> "%",
"White " <> ToString[Round[100data[[5,2]]/total]] <> "%"
},PlotLabel->"Distribution of Ethnic Groups in Students with Math Score > "<>ToString[data[[1]]]]
];

RacialPie[600]

Now we want to compare this to the percentage of students in the math major. The best data it seems we can get is from the NSF Science and Engineering indicators 2014, which show data for Bachelor' s degrees awarded in 2011. Of course, the 3 year lag is a problem, as is the problem is that we' re comparing students now entering with students previously graduating. 
  
But we' re not looking for trends here, just a rough estimate of "the current picture". We get :
  
  18, 021 Math degrees in 2011 (all groups)
        821 awarded to black students
    3, 540 awarded to asian students
     1,152 hispanic
  11, 268 awarded to white students

MathMajors = {{"Math Majors 2011",{"Black",821},{"Asian",3540},{"Hispanic",1152},{"White",11268}}};
USPopRacial = {{ "U.S. Pop",{"Black",13.1},{"Asian",5.3},{"Hispanic",16.9},{"White",77.9}}};
CBSRacial = {{"CBS Pop",{"Black",BlackN},{"Asian",AsianN},{"Hispanic",MexicanN+PuertoricanN+OtherLatinoN},{"White",WhiteN}}};
RacialCombinedWithMath = Join[RacialCombined[[{1,3,5}]],MathMajors,CBSRacial]

RacialSplit = BarChart[
{#[[2,2]],#[[3,2]],#[[4,2]],#[[5,2]]}& /@ RacialCombinedWithMath,ChartLayout->"Percentile",ChartLabels->{{"n=400","500","600","Math Majors","CBS Pop"},{"Black","Asian","Latino","White"}},PlotLabel->"Distribution of Ethnicity\n Students scoring > n on Math SAT,\nMath Majors, College-Bound Seniors"]

Export[NotebookDirectory[]<>"EthnicDistribution.png",RacialSplit,ImageSize->Large]

Export[NotebookDirectory[]<>"EthnicDistribution.pdf",RacialSplit,ImageSize->Large]

Again, we’re worried that sterotype threat might have unfairly reduced the scores of latino, asian, black students. So let’s correct by giving them 50 extra points:

RacialCombined

RacialCorrectedWithMath = Join[MathMajors,{{"450/500",RacialCombined[[2,2]],RacialCombined[[3,3]],RacialCombined[[2,4]],RacialCombined[[3,5]]}},CBSRacial]

RacialCorrectedWithMath2 = Join[MathMajors,{{"450/500",RacialCombined[[4,2]],RacialCombined[[5,3]],RacialCombined[[4,4]],RacialCombined[[5,5]]}},CBSRacial]

RacialSplitCorrected = BarChart[
{#[[2,2]],#[[3,2]],#[[4,2]],#[[5,2]]}& /@ RacialCorrectedWithMath,

ChartLayout->"Percentile",ChartLabels->{{"Math Majors","n=450 (L/B), 500 (W/A)","CBS Pop"},{"Black","Asian","Latino","White"}},PlotLabel->"Distribution of Ethnicity\n Students scoring > n on Math SAT,\nMath Majors, College-Bound Seniors"]

Export[NotebookDirectory[]<>"CorrectedEthnicDistribution.png",RacialSplitCorrected,ImageSize->Large]