Basic Factorial 2 - Balloon Drop

Course MATH 326

Author

Lexi Soelberg

Show the code 
library(mosaic)
library(DT)
library(pander)
library(car)
library(tidyverse)
library(lattice)
library(dplyr)
library(ggplot2)
library(knitr)

# Record your data from your own mini experiment in Excel.
# Save the data as a .csv file in the Data folder of the Statistics-Notebook.


balloon <- read_csv("../../data/BalloonsTwoFactorData.csv")

Balloon Drop Data Collection

Background

We randomized our data. Each balloon was dropped from the Ricks Stairs 5 times bringing a total of 30 drops from our 6 balloons.

Our Two Factors are 3 balloons blown up with 5 breaths of air and 3 balloons blown up with 2 breaths (less air). One of each balloon was weighted either with no weight, a penny taped to the bottom or a quarter taped to the bottom making this a 2 by 3 design. There are 6 total factor combinations. Thus the second factor is weight, nothing, penny, or quarter.

Stephanie dropped all of the balloons from the balcony and Cali and I each had a stop watch at the bottom. We started the time when Stephanie let go of the balloon and stopped the time when any part of the balloon touched the ground. The y variable is the average of the two stop watch times.

Show the code 
library(dplyr)

balloon <- balloon %>%
  select(airmass, weight, avgtime, observation_num)
Show the code 
datatable(balloon, options=list(lengthMenu = c(5,10,30)))

Analysis

EFFECT HYPOTHESES

H_0: \text{Air Mass} (\alpha_\text{i}) = 0 \text{ for all } i

H_a: \text{Air Mass} (\alpha_\text{i}) \ne 0 \text{ for some } i

H_0: \text{Weight}(\beta_\text{j}) = 0 \text{ for all } j

H_a: \text{Weight}(\beta_\text{j}) \ne 0 \text{ for some } j

H_0: \text{Air Mass x Weight}((\alpha\beta)_\text{ij}) = 0 \text{ for all } ij

H_a: \text{Air Mass x Weight}((\alpha\beta)_\text{ij}) \ne 0 \text{ for some } ij

Basic Factorial 2 Mathematical Model

y_{ijk} = \mu + \alpha_i + \beta_j + (\alpha\beta)_\text{ij} \epsilon_{ijk}

Significance level is

\alpha = 0.05

Show the code 
balloon.aov <- aov(avgtime ~ weight*airmass, data=balloon)
summary(balloon.aov) %>% 
  pander()
Analysis of Variance Model
  Df Sum Sq Mean Sq F value Pr(>F)
weight 2 6.457 3.229 896.3 2.826e-23
airmass 1 3.461 3.461 960.9 7.147e-21
weight:airmass 2 0.05379 0.02689 7.466 0.003012
Residuals 24 0.08645 0.003602 NA NA

The ANOVA test tells us that there is significance in comparing the 3 groups and then the interaction between the groups. We see that weight and airmass are significant on their own and the interaction is significant. We need to take a closer look to actually see that difference. We will run some graphs and then a post hoc comparison test to see which groups are different and more different than the others.

Weight Graph

Show the code 
## lets go a ggplot that's real sexy like

library(ggplot2)
library(dplyr)

ggplot(balloon, aes(x=weight, y=avgtime)) +
  geom_boxplot(aes(fill = weight)) +
  theme_bw() +
  scale_fill_manual(values = c("cadetblue1", "brown", "gray")) +
  labs(title = "Time That Balloon Takes to Get to the Floor in Seconds ",
       fill = "Weighted Measure",
       x = "Weights",
       y = "Distance to Floor (seconds)")

Weight Numerical Summary

Show the code 
balloon %>%
  group_by(weight) %>%
  summarise(
    Average = mean(avgtime, na.rm = TRUE),
    Min = min(avgtime, na.rm = TRUE), 
    Med = median(avgtime, na.rm = TRUE), 
    Max = max(avgtime, na.rm = TRUE),
    StDev = sd(avgtime, na.rm = TRUE), 
    SampleSize = n()
  ) %>%
  pander()
weight Average Min Med Max StDev SampleSize
Nothing 2.643 2.185 2.678 3.14 0.4254 10
Penny 1.884 1.53 1.882 2.27 0.3233 10
Quarter 1.531 1.205 1.485 1.93 0.3385 10

Just looking at the nothing weight category we can see that the average is so much greater than the other two weights. The quarter is even greater than the penny but we will have to run comparisons to see the difference.

Air Mass Graph

Show the code 
## lets go a ggplot that's real sexy like

library(ggplot2)
library(dplyr)

ggplot(balloon, aes(x=airmass, y=avgtime)) +
  geom_boxplot(aes(fill = airmass)) +
  theme_bw() +
  scale_fill_manual(values = c("skyblue2", "chartreuse3")) +
  labs(title = "Time That Balloon Takes to Get to the Floor in Seconds ",
       fill = "Air Mass",
       x = "Air Mass",
       y = "Distance to Floor (seconds)")

The graphs are displaying the significant difference we saw in the anova test for air mass. The colors represent the color of balloons that we dropped.

Airmass Numerical Summary

Show the code 
balloon %>%
  group_by(airmass) %>%
  summarise(
    Average = mean(avgtime, na.rm = TRUE),
    Min = min(avgtime, na.rm = TRUE), 
    Med = median(avgtime, na.rm = TRUE), 
    Max = max(avgtime, na.rm = TRUE),
    StDev = sd(avgtime, na.rm = TRUE), 
    SampleSize = n()
  ) %>%
  pander()
airmass Average Min Med Max StDev SampleSize
Large 2.359 1.745 2.165 3.14 0.5238 15
Small 1.68 1.205 1.555 2.365 0.4437 15

This numerical summary is showing a 0.7 second difference between the large and small balloons. When the max is only 3.14 seconds for large that 60th of a second is a big difference as shown to be significant in the anova test.

Interaction Graph

Show the code 
xyplot(as.numeric(avgtime) ~ as.factor(weight), data = balloon, groups=airmass, type=c("p","a"), auto.key=TRUE, 
        main="How Weight and Airmass Affect Balloon Drop Rate", 
        ylab="Distance to Drop (Seconds)", 
        xlab="Weight")

Interaction Numerical Summary

Show the code 
balloon %>%
  group_by(airmass, weight) %>%
  summarise(
    Average = mean(avgtime, na.rm = TRUE),
    Min = min(avgtime, na.rm = TRUE), 
    Med = median(avgtime, na.rm = TRUE), 
    Max = max(avgtime, na.rm = TRUE),
    StDev = sd(avgtime, na.rm = TRUE), 
    SampleSize = n()
  ) %>%
  pander()
airmass weight Average Min Med Max StDev SampleSize
Large Nothing 3.042 2.99 3.005 3.14 0.06428 5
Large Penny 2.187 2.125 2.165 2.27 0.05641 5
Large Quarter 1.848 1.745 1.83 1.93 0.08098 5
Small Nothing 2.244 2.185 2.215 2.365 0.07162 5
Small Penny 1.581 1.53 1.555 1.64 0.0503 5
Small Quarter 1.214 1.205 1.215 1.225 0.008944 5

This is so cool. I love that we see the most variation in the Large Quarter stdev = 0.081 and see the least in the small quarter stdev = 0.009. Obviously the large nothing is much greater than the small quarter.

Show the code 
par(mfrow=c(1,3))
qqPlot(balloon.aov$residuals, id=FALSE)
plot(balloon.aov$fitted.values, balloon.aov$residuals, pch=16)
plot(balloon.aov$residuals, id=FALSE)

The QQ plot shows the normality of the data within the bounds so we can assume that normality assumptions are met.

There is not a megaphone pattern in the residuals vs fitted plot, there is constant variance.

The 3rd plot depicts independance, there are no obvious trends in the data so we can conclude that independance requirements have been met.

We can conclude that all requirements have been met and that we can continue with the interpretation and post hoc tests of the experiment.

Individual Comparisons Between the 6 Balloons

Tukey

Show the code 
balloon.aov <- aov(avgtime ~ airmass * weight, data = balloon)

tukey.aov.balloon <- TukeyHSD(balloon.aov, "airmass:weight")

par(mar = c(4, 8, 3, 1))
plot(tukey.aov.balloon, las = 1)

This Tukey chart is crazy and I’m not sure what to make of it. One of the groups overlaps on the 0 line but I’m not confident in what that means.

Grouping Comparions

Interaction Groupings

Show the code 
library(emmeans)

balloon.means <- emmeans(balloon.aov, ~ airmass * weight, infer = c(TRUE, TRUE))

myContrasts <- contrast(
  balloon.means,
  list(
    LargeNothingvsOthers = c(1, -0.2, -0.2, -0.2, -0.2, -0.2),
    SmallNothingvsOthers   = c(-0.2, 1, -0.2, -0.2, -0.2, -0.2),
    LargePennyvsOthers = c(-0.2, -0.2, 1, -0.2, -0.2, -0.2),
    SmallPennyvsOthers = c(-0.2, -0.2, -0.2, 1, -0.2, -0.2),
    LargeQuartervsOthers   = c(-0.2, -0.2, -0.2, -0.2, 1, -0.2),
    SmallQuartervsOthers = c(-0.2, -0.2, -0.2, -0.2, -0.2, 1)
  ),
  adjust = "scheffe"
)

myContrasts
 contrast             estimate     SE df t.ratio p.value
 LargeNothingvsOthers    1.227 0.0294 24  41.738 <0.0001
 SmallNothingvsOthers    0.270 0.0294 24   9.169 <0.0001
 LargePennyvsOthers      0.201 0.0294 24   6.843 <0.0001
 SmallPennyvsOthers     -0.526 0.0294 24 -17.890 <0.0001
 LargeQuartervsOthers   -0.206 0.0294 24  -6.993 <0.0001
 SmallQuartervsOthers   -0.966 0.0294 24 -32.868 <0.0001

P value adjustment: scheffe method with rank 5

Again like the numerical summary, the nerd in me is so excited. This shows that none of the balloons are the same as the others. I want to run another scheffe that shows the a, b, cs to check.

Show the code 
library(agricolae)

balloon$Group <- with(balloon, interaction(airmass, weight))
balloon.aov2 <- aov(avgtime ~ Group, data = balloon)
scheffe.test(balloon.aov2, "Group", console = TRUE)

Study: balloon.aov2 ~ "Group"

Scheffe Test for avgtime 

Mean Square Error  : 0.003602083 

Group,  means

              avgtime         std r         se   Min   Max   Q25   Q50   Q75
Large.Nothing   3.042 0.064284524 5 0.02684058 2.990 3.140 3.000 3.005 3.075
Large.Penny     2.187 0.056413651 5 0.02684058 2.125 2.270 2.160 2.165 2.215
Large.Quarter   1.848 0.080978392 5 0.02684058 1.745 1.930 1.805 1.830 1.930
Small.Nothing   2.244 0.071624018 5 0.02684058 2.185 2.365 2.205 2.215 2.250
Small.Penny     1.581 0.050299105 5 0.02684058 1.530 1.640 1.550 1.555 1.630
Small.Quarter   1.214 0.008944272 5 0.02684058 1.205 1.225 1.205 1.215 1.220

Alpha: 0.05 ; DF Error: 24 
Critical Value of F: 2.620654 

Minimum Significant Difference: 0.1374032 

Means with the same letter are not significantly different.

              avgtime groups
Large.Nothing   3.042      a
Small.Nothing   2.244      b
Large.Penny     2.187      b
Large.Quarter   1.848      c
Small.Penny     1.581      d
Small.Quarter   1.214      e

Wait this is crazy, small nothing is not different than large penny. Their means are 2.165 (large penny) and 2.215 (small nothing). That is only a .05 of a second difference. I need to take a closer look. Let me run another comparison to check closer.

Show the code 
library(emmeans)

balloon2.means <- emmeans(balloon.aov, ~ airmass * weight, infer = c(TRUE, TRUE))

myContrasts2 <- contrast(
  balloon2.means,
  list(
    SmallNothingvsLargePenny = c(0, 1, -1, 0, 0, 0)
  ),
  adjust = "scheffe"
)

myContrasts2
 contrast                 estimate    SE df t.ratio p.value
 SmallNothingvsLargePenny    0.057 0.038 24   1.502  0.1462

P value adjustment: scheffe method with rank 1

The p-value is not significant! This is the finding I was looking for. With 6 distinctive balloons it’s almost more interesting to find that one or more of the groups are not significant with each other. So cool to see.

Each Weight Vs Other

Show the code 
library(emmeans)

balloonw.means <- emmeans(balloon.aov, "weight", infer=c(TRUE,TRUE))

myContrastsw <- contrast(balloonw.means, list(`NothingvsOthers`=c(1,-0.5,-0.5),
                                      `PennyvsOthers`=c(-0.5, 1, -0.5), 
                                      `QuartervsOthers`=c(-0.5, -0.5, 1)),adjust="scheffe")
myContrastsw
 contrast        estimate     SE df t.ratio p.value
 NothingvsOthers    0.935 0.0232 24  40.246 <0.0001
 PennyvsOthers     -0.203 0.0232 24  -8.733 <0.0001
 QuartervsOthers   -0.733 0.0232 24 -31.513 <0.0001

Results are averaged over the levels of: airmass 
P value adjustment: scheffe method with rank 2

This shows that each group is unique but that’s not that interesting to me. I want to directly compare penny and quarter times since they were closer than the nothing group. I am going to run another contrast.

Penny vs Quarter

Show the code 
library(emmeans)

balloonw2.means <- emmeans(balloon.aov, "weight", infer=c(TRUE,TRUE))

myContrastsw2 <- contrast(balloonw2.means, list(`PennyvsQuarter`=c(0, 1, -1) 
                                      ),adjust="scheffe")
myContrastsw2 
 contrast       estimate     SE df t.ratio p.value
 PennyvsQuarter    0.353 0.0268 24  13.152 <0.0001

Results are averaged over the levels of: airmass 
P value adjustment: scheffe method with rank 1

Still very significant. Nice I like it.

There is no reason for me to run a contrast for Air Mass since that factor only has 2 levels unlike the weight that has 3.

(I ran all the different post hocs and didn’t want to straight up delete them)

Fisher’s LSD

Show the code 
ball.fish <- pairwise.t.test(balloon$avgtime, balloon$weight, "none")
ball.fish

    Pairwise comparisons using t tests with pooled SD 

data:  balloon$avgtime and balloon$weight 

        Nothing Penny
Penny   7.9e-05 -    
Quarter 2.6e-07 0.04 

P value adjustment method: none

Bonferonni

Show the code 
ball.bon <- pairwise.t.test(balloon$avgtime, balloon$weight, "bonferroni")
ball.bon

    Pairwise comparisons using t tests with pooled SD 

data:  balloon$avgtime and balloon$weight 

        Nothing Penny  
Penny   0.00024 -      
Quarter 7.8e-07 0.11913

P value adjustment method: bonferroni

Tukey

Show the code 
tukey.aov.balloon <- TukeyHSD(balloon.aov, "weight")
par(mar=c(4,8,3,1))
plot(tukey.aov.balloon, las=1)

In this Tukey chart we see that none of the groups overlap on the 0 line so they are all different from eachother. I chose the Tukey test because I want to keep my Type 1 error low. I also want to see the confidence intervals.

Scheffé

Show the code 
library(agricolae)

scheffe.test(balloon.aov, "weight", console=TRUE)

Study: balloon.aov ~ "weight"

Scheffe Test for avgtime 

Mean Square Error  : 0.003602083 

weight,  means

        avgtime       std  r         se   Min  Max     Q25    Q50     Q75
Nothing   2.643 0.4254488 10 0.01897916 2.185 3.14 2.22375 2.6775 3.00375
Penny     1.884 0.3233402 10 0.01897916 1.530 2.27 1.57375 1.8825 2.16375
Quarter   1.531 0.3385328 10 0.01897916 1.205 1.93 1.21625 1.4850 1.82375

Alpha: 0.05 ; DF Error: 24 
Critical Value of F: 3.402826 

Minimum Significant Difference: 0.07002075 

Means with the same letter are not significantly different.

        avgtime groups
Nothing   2.643      a
Penny     1.884      b
Quarter   1.531      c

Interpretation

It would appear that each balloon is different but when I ran and interaction Sheffé test on the individual balloons I found that Small Nothing and Large Penny were not found to be different than each other. This is very interesting data because it felt like each balloon was totally different. This is the most interesting finding in this analysis. p-value = .1462 > \alpha

All other interaction groups were significantly different than each other. p-value = 0.001 < \alpha

: )

Back to top