Download data

Downloading data from the website. The download command downloads data in the working directory.

Data are downloaded, loaded, and names of fields are read from the file:

setInternet2(TRUE) # solution for https files

download.file("https://sites.google.com/site/statsr4us/intro/software/rcmdr-1/TeachingRatings.rda", "TeachingRatings.rda")

load("TeachingRatings.rda")

setwd("C:/Users/Murtaza/Google Drive/AEBE/Data/ch.04/R_ch04")

names(TeachingRatings)
##  [1] "minority"    "age"         "gender"      "credits"     "beauty"     
##  [6] "eval"        "division"    "native"      "tenure"      "students"   
## [11] "allstudents" "prof"

Loading required packages and attaching the data set.

library(xtable)
## Warning: package 'xtable' was built under R version 3.1.3
library(psych)
## Warning: package 'psych' was built under R version 3.1.3
library(htmlTable)
## Warning: package 'htmlTable' was built under R version 3.1.3
attach(TeachingRatings)

Descriptive stats on continuous varaiables

TAble 4-18

tab <- xtable(describe(cbind(age, beauty, eval, students, allstudents), 
                       skew=F, ranges=T))
print(tab, type="html")
vars n mean sd median trimmed mad min max range se
age 1 463.00 48.37 9.80 48.00 48.35 11.86 29.00 73.00 44.00 0.46
beauty 2 463.00 0.00 0.79 -0.07 -0.05 0.87 -1.45 1.97 3.42 0.04
eval 3 463.00 4.00 0.55 4.00 4.03 0.59 2.10 5.00 2.90 0.03
students 4 463.00 36.62 45.02 23.00 27.54 14.83 5.00 380.00 375.00 2.09
allstudents 5 463.00 55.18 75.07 29.00 38.66 19.27 8.00 581.00 573.00 3.49

Subset data by professors

Professor specific variables:

  • age
  • beauty

Identifying duplicates for subsetting

profs <- subset(TeachingRatings, !duplicated(TeachingRatings$prof))
attach(profs)

Descriptive statistics

Table 4-19

tab <- xtable(describe(cbind(age, beauty), skew=F, ranges=F))
print(tab, type="html")
vars n mean sd se
age 1 94.00 47.55 10.26 1.06
beauty 2 94.00 0.09 0.83 0.09

Evaluation Factors:

  • minority
  • Gender
  • Native
  • Tenure
attach(TeachingRatings)

Average evaluation by gender

psych package

Table 4-20

tab <- xtable(describeBy(eval, gender, mat=T, skew=F, ranges=T))
print(tab, type="html")
item group1 vars n mean sd median trimmed mad min max range se
11 1 male 1.00 268.00 4.07 0.56 4.15 4.10 0.52 2.10 5.00 2.90 0.03
12 2 female 1.00 195.00 3.90 0.54 3.90 3.92 0.59 2.30 4.90 2.60 0.04 
tab<-xtable(cbind("Teaching Evaluations"=tapply(eval, gender, mean)))
print(tab, type="html")
Teaching Evaluations
male 4.07
female 3.90

Average evaluation by tenure

Table 4-21

tab<-cbind("Teaching Evaluations"=tapply(eval, tenure, mean))
htmlTable(txtRound(tab,2),rowlabel = "Tenure status")
Tenure status Teaching Evaluations
no 4.13
yes 3.96 
tab<-xtable(cbind("Teaching Evaluations"=tapply(eval, tenure, mean)))
print(tab, type="html")
Teaching Evaluations
no 4.13
yes 3.96

Average evaluation by tenure and gender

Table 4-22

tab<-cbind("Teaching Evaluation"=tapply(eval, list(tenure, gender), mean))

htmlTable(txtRound(tab,2), 
          cgroup = c("Gender"), n.cgroup = c(2),
          rowlabel = "Tenure Status")
Gender
Tenure Status male female
no 4.40 3.86
yes 3.99 3.92

Table 4-23 and 4-24

f <- function(x) c(obs=length(x), mean=mean(x), sd=sd(x))
tres<-as.matrix(aggregate(eval ~ gender+tenure, FUN=c("f")))
htmlTable(txtRound(tres,0,excl.cols = c(1,2,4,5)))
gender tenure eval.obs eval.mean eval.sd
male no 52 4.3961538 0.5048632
female no 50 3.8600000 0.4733726
male yes 216 3.9902778 0.5405836
female yes 145 3.9151724 0.5604228 
colnames(tres)[3:5]<-c("n", "mean", "std. dev.")
htmlTable(txtRound(tres,0,excl.cols = c(1,2,4,5)))
gender tenure n mean std. dev.
male no 52 4.3961538 0.5048632
female no 50 3.8600000 0.4733726
male yes 216 3.9902778 0.5405836
female yes 145 3.9151724 0.5604228

Average evaluation by tenure, gender, and minority

Table 4-25

f <- function(x) c(obs=length(x), mean=mean(x), sd=sd(x))
tres<-as.matrix(aggregate(eval ~ gender+tenure+minority, FUN=c("f")))
colnames(tres)[4:6]<-c("n", "mean", "std. dev.")
htmlTable(txtRound(tres,0,excl.cols = c(1,2,3,5,6)))
gender tenure minority n mean std. dev.
male no no 42 4.3047619 0.5174762
female no no 50 3.8600000 0.4733726
male yes no 198 4.0156566 0.5394181
female yes no 109 3.9743119 0.5644407
male no yes 10 4.7800000 0.1475730
male yes yes 18 3.7111111 0.4837220
female yes yes 36 3.7361111 0.5150050

Summarising eval and beauty by gender

Table 4-26

f <- function(x) c(obs=length(x), mean=mean(x), sd=sd(x))
tres<-t(as.matrix(aggregate(cbind(eval, beauty) ~ gender, FUN=c("f"))))
rownames(tres)[2:7]<-c("n", "mean", "std. dev.", "n", "mean", "std. dev.")
htmlTable(txtRound(tres,0, excl.rows = c(3,4,6,7)),
          rgroup=c("","evaluation score","beauty score"),
          n.rgroup = c(1,3,3))
gender male female
evaluation score
  n 268 195
  mean 4.0690299 3.9010256
  std. dev. 0.5566518 0.5388026
beauty score
  n 268 195
  mean -0.08448224 0.11610907
  std. dev. 0.75712993 0.81780964

Average evaluation by minority

tab<-xtable(cbind("Teaching Evaluation"=tapply(eval, minority, mean)))
print(tab, type="html")
Teaching Evaluation
no 4.02
yes 3.89

Average evaluation by native English speaking

tab<-xtable(cbind("Teaching Evaluation"=tapply(eval, native, mean)))
print(tab, type="html")
Teaching Evaluation
yes 4.02
no 3.69

..

Correlation between beauty and evaluation

Table 4-27

myvars<- c("eval", "beauty", "age", "students", "allstudents")
x <- TeachingRatings[myvars]
tab <-xtable(cor(x), digits=3)
print(tab, type="html")
eval beauty age students allstudents
eval 1.000 0.189 -0.052 0.035 -0.001
beauty 0.189 1.000 -0.298 0.131 0.100
age -0.052 -0.298 1.000 -0.030 -0.013
students 0.035 0.131 -0.030 1.000 0.972
allstudents -0.001 0.100 -0.013 0.972 1.000

Reproducing Table 1 from Hamermesh paper

Generate SD Function

my.wsd<-  function(w, x, wx, n)  sqrt(sum(w*(x-wx)^2)/((n-1)*sum(w)/n))

Generate Percent evaluating

TeachingRatings$p.eval <- students/allstudents*100

All Results

attach(TeachingRatings)
wm.course <-weighted.mean(eval,students); wm.course
## [1] 4.02241
wsd.course<-my.wsd(students,eval, wm.course, length(eval)) ; wsd.course
## [1] 0.5249643
m.studs <- mean(allstudents); sd.studs <-sd(allstudents); m.studs
## [1] 55.17711
m.peval <-mean(p.eval); m.peval
## [1] 74.42779
tabgen<-xtabs(students~gender)/sum(students); tabgen
## gender
##      male    female 
## 0.6406204 0.3593796
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##         no        yes 
## 0.90127971 0.09872029
tabeng<-xtabs(students~native)/sum(students); tabeng
## native
##        yes         no 
## 0.96343693 0.03656307
tabten<-xtabs(students~tenure)/sum(students); tabten
## tenure
##       no      yes 
## 0.149024 0.850976
tabdiv<-table(division)/sum(table(division)); tabdiv
## division
##     upper     lower 
## 0.6609071 0.3390929
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##         no        yes 
## 0.90127971 0.09872029
courses <- length(eval); courses
## [1] 463
faculty <- length(unique(prof)); faculty
## [1] 94
all.res<- rbind(wm.course, wsd.course, m.studs, sd.studs, m.peval, female=tabgen[2],
      minority=tabmin[2], 'native english' =tabeng[2], tenure = tabten[2],
      "lower division" = tabdiv[2], courses, faculty); all.res
##                      female
## wm.course        4.02240962
## wsd.course       0.52496430
## m.studs         55.17710583
## sd.studs        75.07279984
## m.peval         74.42778824
## female           0.35937961
## minority         0.09872029
## native english   0.03656307
## tenure           0.85097600
## lower division   0.33909287
## courses        463.00000000
## faculty         94.00000000
colnames(all.res) <- "all courses"; all.res
##                 all courses
## wm.course        4.02240962
## wsd.course       0.52496430
## m.studs         55.17710583
## sd.studs        75.07279984
## m.peval         74.42778824
## female           0.35937961
## minority         0.09872029
## native english   0.03656307
## tenure           0.85097600
## lower division   0.33909287
## courses        463.00000000
## faculty         94.00000000

Subset Lower

lower <- subset(TeachingRatings, subset=division =="lower")
attach(lower)
wm.course <-weighted.mean(eval,students); wm.course
## [1] 4.060476
wsd.course<-my.wsd(students,eval, wm.course, length(eval)) ; wsd.course
## [1] 0.5634478
m.studs <- mean(allstudents); sd.studs <-sd(allstudents); m.studs
## [1] 76.50318
m.peval <-mean(p.eval); m.peval
## [1] 73.52339
tabgen<-xtabs(students~gender)/sum(students); tabgen
## gender
##      male    female 
## 0.6995807 0.3004193
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##        no       yes 
## 0.8904369 0.1095631
tabeng<-xtabs(students~native)/sum(students); tabeng
## native
##         yes          no 
## 0.993236846 0.006763154
tabten<-xtabs(students~tenure)/sum(students); tabten
## tenure
##        no       yes 
## 0.1719194 0.8280806
tabdiv<-table(division)/sum(table(division)); tabdiv
## division
## upper lower 
##     0     1
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##        no       yes 
## 0.8904369 0.1095631
courses <- length(eval); courses
## [1] 157
faculty <- length(unique(prof)); faculty
## [1] 42
lower.res<-rbind(wm.course, wsd.course, m.studs, sd.studs, m.peval, female=tabgen[2],
      minority=tabmin[2], 'native english' =tabeng[2], tenure = tabten[2],
      "lower division" = tabdiv[2], courses, faculty); lower.res
##                      female
## wm.course      4.060476e+00
## wsd.course     5.634478e-01
## m.studs        7.650318e+01
## sd.studs       1.092869e+02
## m.peval        7.352339e+01
## female         3.004193e-01
## minority       1.095631e-01
## native english 6.763154e-03
## tenure         8.280806e-01
## lower division 1.000000e+00
## courses        1.570000e+02
## faculty        4.200000e+01
colnames(lower.res) <- "lower division"; lower.res
##                lower division
## wm.course        4.060476e+00
## wsd.course       5.634478e-01
## m.studs          7.650318e+01
## sd.studs         1.092869e+02
## m.peval          7.352339e+01
## female           3.004193e-01
## minority         1.095631e-01
## native english   6.763154e-03
## tenure           8.280806e-01
## lower division   1.000000e+00
## courses          1.570000e+02
## faculty          4.200000e+01

Subset Upper

upper <- subset(TeachingRatings, subset=division =="upper")

attach(upper)

wm.course <-weighted.mean(eval,students); wm.course
## [1] 3.992984
wsd.course<-my.wsd(students,eval, wm.course, length(eval)) ; wsd.course
## [1] 0.4924672
m.studs <- mean(allstudents); sd.studs <-sd(allstudents); m.studs
## [1] 44.23529
m.peval <-mean(p.eval); m.peval
## [1] 74.89181
tabgen<-xtabs(students~gender)/sum(students); tabgen
## gender
##      male    female 
## 0.5950439 0.4049561
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##         no        yes 
## 0.90966123 0.09033877
tabeng<-xtabs(students~native)/sum(students); tabeng
## native
##        yes         no 
## 0.94040151 0.05959849
tabten<-xtabs(students~tenure)/sum(students); tabten
## tenure
##        no       yes 
## 0.1313258 0.8686742
tabdiv<-table(division)/sum(table(division)); tabdiv
## division
## upper lower 
##     1     0
tabmin<-xtabs(students~minority)/sum(students); tabmin
## minority
##         no        yes 
## 0.90966123 0.09033877
courses <- length(eval); courses
## [1] 306
faculty <- length(unique(prof)); faculty
## [1] 79
upper.res<-rbind(wm.course, wsd.course, m.studs, sd.studs, m.peval, female=tabgen[2],
      minority=tabmin[2], 'native english' =tabeng[2], tenure = tabten[2],
      "lower division" = tabdiv[2], courses, faculty);upper.res
##                      female
## wm.course        3.99298411
## wsd.course       0.49246723
## m.studs         44.23529412
## sd.studs        45.54050832
## m.peval         74.89181028
## female           0.40495609
## minority         0.09033877
## native english   0.05959849
## tenure           0.86867419
## lower division   0.00000000
## courses        306.00000000
## faculty         79.00000000
colnames(upper.res) <- "upper division" ; upper.res
##                upper division
## wm.course          3.99298411
## wsd.course         0.49246723
## m.studs           44.23529412
## sd.studs          45.54050832
## m.peval           74.89181028
## female             0.40495609
## minority           0.09033877
## native english     0.05959849
## tenure             0.86867419
## lower division     0.00000000
## courses          306.00000000
## faculty           79.00000000

Final Table

tab <-xtable(cbind(all.res, lower.res, upper.res), digits=3)
print(tab, type="html")
all courses lower division upper division
wm.course 4.022 4.060 3.993
wsd.course 0.525 0.563 0.492
m.studs 55.177 76.503 44.235
sd.studs 75.073 109.287 45.541
m.peval 74.428 73.523 74.892
female 0.359 0.300 0.405
minority 0.099 0.110 0.090
native english 0.037 0.007 0.060
tenure 0.851 0.828 0.869
lower division 0.339 1.000 0.000
courses 463.000 157.000 306.000
faculty 94.000 42.000 79.000