Το Clothing Color and Tipping: Gentlemen Patrons Give More Tips to Waitresses with Red Clothes ερευνά την επίδραση του χρώματος ενδυμασίας μιας γυναίκας στην έλξη που δημιουργεί σ’ έναν άντρα. Ένας τρόπος εξέτασης αυτού ήταν η εξέταση του φιλοδωρήματος που εισπράττει μια σερβιτόρα φορώντας κόκκινο κοντομάνικο ή μπλε κ.τ.λ. Οι διαφορές που παρουσιάζονται είναι εντυπωσιακές με γυμνό μάτι. Για παράδειγμα, όταν οι κοπέλες φορούσαν κόκκινο μπλουζάκι, από τους 69 πελάτες, οι 40 (δηλαδή το 58%) έδωσαν φιλοδώρημα. Από την άλλη όταν αυτές φορούσαν μαύρο μπλουζάκι μόνο οι 20 από τους 71 πελάτες (το 28%) έδωσαν φιλοδώρημα. Για περισσότερες λεπτομέρειες δείτε τον κάτωθι πίνακα.
| Μαύρο | Άσπρο | Κόκκινο | Κίτρινο | Μπλε | Πράσινο | |
| Άνδρες που έδωσαν φιλοδώρημα | 22 | 25 | 40 | 31 | 25 | 27 |
| Σύνολο ανδρών πελατών | 71 | 68 | 69 | 73 | 67 | 70 |
Οι διαφορές είναι εντυπωσιακές και όσον αφορά το μέγεθος του φιλοδωρήματος. Αυτές που φορούσαν κόκκινο μπλουζάκι πήραν κατά μέσο όρο 1.30€ φιλοδώρημα, ενώ π.χ. αυτές που φορούσαν μαύρο φιλοδωρήθηκαν κατά μέσο όρο με 0.96€.
| Μαύρο | Άσπρο | Κόκκινο | Κίτρινο | Μπλε | Πράσινο | |
| Μέσο φιλοδώρημα ανά άνδρα | 0.96€ | 0.96€ | 1.30€ | 1.11€ | 1.01€ | 0.96€ |
| Τυπική απόκλιση | 0.27€ | 0.36€ | 0.46€ | 0.42€ | 0.34€ | 0.34€ |
Ένα επίσης εντυπωσιακό στοιχείο, με το οποίο όμως δε θα καταπιαστούμε εδώ, είναι ότι το κόκκινο χρώμα έχει την μικρότερη απήχηση στον γυναικείο πληθυσμό (28.3%).
Για να προχωρήσει η δικιά μας έρευνα, θα χρειαστούμε τη μέση τιμή του φιλοδωρήματος όλων των αντρών που δίνουν κάποιο φιλοδώρημα (μελετούμε μόνο αυτούς που δίνουν φιλοδώρημα κι όχι αυτούς που δεν δίνουν, διότι εξετάζουμε την επιρροή της ενδυμασίας στην ποσότητα φιλοδωρήματος κι όχι στο κίνητρο να δώσει κάποιος ή όχι). Δυστυχώς εδώ έχουμε διαθέσιμους μόνο 170 πελάτες και όχι όλους τους πελάτες όλων των καφετεριών της Γης. Σαν να μην έφτανε αυτό δεν διαθέτουμε ούτε το μέσο φιλοδώρημα που δέχονται οι σερβιτόρες στην καφετέρια, αλλά έχουμε ξεχωριστά τα φιλοδωρήματα ανάλογα με το μπλουζάκι της κάθε μίας.
Το δεύτερο πρόβλημα για να λυθεί χρειάστηκαν λίγα περίεργα μαθηματικά. Όχι κάτι παραπάνω από Α’ Λυκείου, αλλά αρκετά για να εξοστρακιστούν από αυτή τη σελίδα. Παραταύτα παραθέτουμε ένα πρόγραμμα στην R που να κάνει τη δουλειά του υπολογισμού του μέσου φιλοδωρήματος έχοντας διαθέσιμα τα επιμέρους φιλοδωρήματα:
m1 <- as.numeric(readline(prompt="Δώσε 1η μέση τιμή: "))
n1 <- as.numeric(readline(prompt="Δώσε 1ο πλήθος τιμών: "))
Sm <- m1*n1
Sn <- n1
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
while (test != 'Q') {
m_a <- as.numeric(readline(prompt="Δώσε επόμενη μέση τιμή: "))
n_a <- as.numeric(readline(prompt="Δώσε επόμενο πλήθος τιμών: "))
Sm <- m_a*n_a+Sm
Sn <- n_a+Sn
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
}
Sm/SnΤο ίδιο πρόβλημα αντιμετωπίζουμε και με την τυπική απόκλιση. Έχουμε τις επιμέρους τυπικές αποκλίσεις, αλλά δεν έχουμε την τυπική απόκλιση από τα φιλοδωρήματα γενικώς. Πάλι θα κάνει τη δουλειά μας ένα άλλο προγραμματάκι. Αυτό θα είναι μια τροποποίηση του παραπάνω, καθόσον θα μας χρειάζονται και πάλι οι μέσες τιμές:
m1 <- as.numeric(readline(prompt="Δώσε 1η μέση τιμή: "))
n1 <- as.numeric(readline(prompt="Δώσε 1ο πλήθος τιμών: "))
s1 <- as.numeric(readline(prompt="Δώσε 1η τυπική απόκλιση: "))
Sm <- m1*n1
Sn <- n1
Sq <- (s1^2)*(n1-1)+n1*m1^2
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
while (test != 'Q') {
m_a <- as.numeric(readline(prompt="Δώσε επόμενη μέση τιμή: "))
n_a <- as.numeric(readline(prompt="Δώσε επόμενο πλήθος τιμών: "))
s_a <- as.numeric(readline(prompt="Δώσε επόμενη τυπική απόκλιση: "))
Sm <- m_a*n_a+Sm
Sn <- n_a+Sn
Sq <- Sq+(s_a^2)*(n_a-1)+n_a*m_a^2
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
}
m <- Sm/Sn
m
sqrt((Sq-Sn*m^2)/(Sn-1))Βρήκαμε λοιπόν ότι οι σερβιτόρες σε αυτή την καφετέρια την περίοδο
της στατιστικής έρευνας αυτής φιλοδωρούνται με κατά μέσο όρο 1.089412€
με τυπική απόκλιση 0.3733317€. Πάμε να κάνουμε τώρα μια εκτίμηση της
μέσης τιμής του πληθυσμού. Προς τούτο θα χρησιμοποιήσουμε τη συνάρτηση
DiastEmpist() που είχαμε δημιουργήσει παλαιότερα (βλ.
ενότητα Διάστημα
εμπιστοσύνης).
DiastEmpist <- function(mesi_timi, tipiki_apokl, plithos, pith) {
s <- tipiki_apokl/sqrt(plithos)
a <- (1-pith)/2
t <- qt(a, plithos-1, lower.tail=F)
m1 <- mesi_timi-t*s
m2 <- mesi_timi+t*s
c(m1, m2)
}Οπότε γράφουμε:
## [1] 1.032887 1.145937Συνεπώς βρίσκουμε ότι είναι σίγουρο κατά 95% ότι οι σερβιτόρες δέχονται φιλοδώρημα μεταξύ των 1.032887€ και 1.145937€, δηλαδή ανάμεσα στα 1€3Λ και 1€14Λ. Αυτό σημαίνει ότι η δειγματική μέση τιμή 1.089412€ (1€9Λ) είναι αρκετά αντιπροσωπευτική. Όλα αυτά ισχύουν εφόσον, φυσικά, στην καφετέρια αυτή δεν συμβαίνει κάτι το ιδιαίτερο που να κάνει τα φιλοδωρήματα να είναι μεγαλύτερα ή μικρότερα απ’ ό,τι συνήθως.
Στις παρακάτω ενότητες θα εξετάσουμε αν η κόκκινη ενδυμασία επηρεάζει το μέγεθος του φιλοδωρήματος.
Η μηδενική υπόθεση, προφανώς, θα ισχυρίζεται πως η ενδυμασία έχει μηδενική επίδραση στο φιλοδώρημα. Θα υποστηρίζει ότι ακόμα κι αν ντύναμε όλες τις σερβιτόρες με κόκκινα ρούχα, ακόμα και τότε το φιλοδώρημα θα ήταν κατά μέσο όρο πάλι 1.09€ ανά άτομο.
Η εναλλακτική υπόθεση, κατά τα γνωστά, θα ισχυρίζεται πως η ενδυμασία ασκεί μια επίδραση στον άντρα, η οποία αντικατοπτρίζεται στη γενναιοδωρία που επιδεικνύει στην γυναίκα που φοράει κόκκινα ρούχα. Με άλλα λόγια, θα υποστηρίζει ότι, αν ντύναμε στα κόκκινα όλες τις σερβιτόρες, τότε το μέσο φιλοδώρημα θα διαφοροποιούνταν.
Πώς διαψεύδεται σ’ αυτή την περίπτωση η μηδενική υπόθεση; Στην ενότητα Τιμή σημαντικότητας – (p-τιμή) εξηγήσαμε πως η \(\boldsymbol{\mathcal{H}_0}\) διαψεύδεται όταν καταλήγει να θεωρεί απίθανα τα γεγονότα που παρατηρούμε. Έτσι κι εδώ! Θα πρέπει να απαντήσουμε τα παρακάτω ερωτήματα:
Είναι αναμενόμενες διαφοροποιήσεις δειγματικών μέσων τιμών σαν την δειγματική μέση τιμή 1.30€ ή και χειρότερες, οπότε η \(\boldsymbol{\mathcal{H}_0}\) δεν μπορεί ν’ απορριφθεί;
Ή μήπως αυτές οι διαφοροποιήσεις είναι κάτι το απίθανο, οπότε θα πρέπει να απορρίψουμε την σφαλερή υπόθεση \(\boldsymbol{\mathcal{H}_0}\), υποστηρίζοντας ότι λογικά θα είναι τελικά κάτι όντως ξεχωριστό το φιλοδώρημα τν 1.30€ στην περίπτωση που φοράνε κόκκινα μπλουζάκια;
Για να απαντήσουμε αυτά τα ερωτήματα θα χρειαστούμε τη συνάρτηση
p_timi(🔪🔪🔪,💞💞💞, 🗡🗡️🗡,👦👦👦).
Στη θέση του 🔪🔪🔪 γράφουμε τη μέση τιμή που
παρατηρούμε στο τμήμα του δείγματος με τα κόκκινα μπλουζάκια (εδώ αυτή
είναι 1.30€),
στη θέση του 💞💞💞 γράφουμε την τυπική απόκλιση
όλου του δείγματος (αυτή που βρήκαμε ότι είναι 0.3733317€, όχι την 0.46€
που αφορούσε τα κόκκινα μπλουζάκια),
στη θέση του 🗡️🗡️🗡️ γράφουμε την μέση τιμή του
πληθυσμού (δηλαδή τα 1.089412€) και
στη θέση του 👨👨👨 το μέγεθος όλου του δείγματος
(το οποίο είναι εδώ 170 πελάτες).
Η συνάρτηση που θέλαμε είναι η κάτωθι:
p_timi <- function(mesi_timiDigm, tipiki_apoklPlith, mesi_timiPlith, plithos) {
a <- abs(mesi_timiDigm-mesi_timiPlith)
s <- tipiki_apoklPlith/sqrt(plithos)
2-2*pt(a/s, plithos-1)
}Οπότε γράφουμε:
## [1] 7.890133e-12Και βρίσκουμε ότι η p-τιμή είναι 7.890133e-12, δηλαδή η πιθανότητα να τύχουμε δείγμα με τέτοιο μέσο φιλοδώρημα από έναν πληθυσμό που φιλοδωρεί κατά μέσο όρο με 1.09€ είναι \(7.890133\cdot 10^{-12}\approx\frac{8}{1000000000000}\).
Όμως πόσο μικρή είναι αυτή η πιθανότητα; Ας φανταστούμε το εξής τυχερό παιχνίδι: Βρίσκεστε σε μια παραλία ενός στρέμματος και διαλέγετε έναν απλό κόκκο άμμου. Τοποθετείτε κάπου στην παραλία αυτόν τον κόκκο άμμου (μπορείτε και να σκάψετε και να τον θάψετε!) και και μετά καλούμαι εγώ να τον βρω. Η πιθανότητα να διαλέξω έναν κόκκο άμμου στην τύχη και να είναι αυτός που κρύψατε, η πιθανότητα να τον βρω, δηλαδή, με τη μία είναι μεγαλύτερη από την πιθανότητα \(\frac{8}{1000000000000}\) που βρήκαμε πριν.
Συνεπώς, συμπεραίνουμε ότι το να τύχουμε κάποιο τόσο ακραίο φιλοδώρημα δεν είναι καθόλου πιθανό. Επομένως οφείλουμε να απορρίψουμε τη μηδενική υπόθεση, δηλαδή το ότι τίποτα το αξιοπερίεργο δεν συμβαίνει, και να υιοθετήσουμε την εναλλακτική υπόθεση, ότι δηλαδή το κόκκινο χρώμα της μπλούζας ασκεί κάποια επίδραση στο μέγεθος του φιλοδωρήματος.
Εναλλακτική προσέγγιση στο ζήτημα, όπως έχουμε δει και στην ενότητα Επίπεδο σημαντικότητας – (α-τιμή), θα ήταν να βρίσκαμε πρώτα το επίπεδο σημαντικότητας και κατόπιν να ελέγχαμε αν το δείγμα μας ήταν στατιστικά σημαντικό. Έτσι λοιπόν, όπως και εκεί, έτσι κι εδώ θα θεωρήσουμε ως επίπεδο σημαντικότητας το α=0.05. Ψάχνουμε, δηλαδή, το 5% των πιο ακραίων δειγμάτων, αυτών που το μέσο φιλοδώρημα είναι είτε αρκετά πιο γενναιόδωρο είτε αρκετά πιο φειδωλό από το μέσο των 1.09€ ανά πελάτη.
Από αυτά που προλέχθηκαν καταλαβαίνουμε ότι ψάχνουμε το 2.5% των πιο μεγάλων μέσων φιλοδωρημάτων και το 2.5% των πιο μικρών, ώστε να έχουμε συνολικά το 5% των πιο ακραίων. Με άλλα λόγια, ψάχνουμε δύο νούμερα, ανάμεσα στα οποία να βρίσκονται τα συνηθισμένα φιλοδωρήματα και έξω από τα οποία να βρίσκονται τα αφύσικα, τα σπάνια, αυτά που υπό φυσιολογικές συνθήκες θα είχαν μόνο 5% πιθανότητα να συμβούν.
Για να υπολογιστούν αυτά θα χρησιμοποιήσουμε τη συνάρτηση
a_timi(🗡️🗡️🗡️, 💞💞💞, 👨👨👨, 👑👑👑).
Στη θέση του 🗡️🗡️🗡️ γράφουμε την μέση τιμή του
πληθυσμού (δηλαδή τα 1.089412€),
στη θέση του 💞💞💞 γράφουμε την τυπική απόκλιση
όλου του δείγματος (αυτή που βρήκαμε ότι είναι 0.3733317€, όχι την 0.46€
που αφορούσε τα κόκκινα μπλουζάκια),
στη θέση του 👨👨👨 το μέγεθος όλου του δείγματος
(το οποίο είναι εδώ 170 πελάτες) και
στη θέση του 👑👑👑 θα πάει το ποσοστό που θεωρούμε
ότι αντιπροσωπεύει τα σπάνια συμβάντα, το οποίο σε μας είναι το 5%,
δηλαδή το 0.05.
a_timi <- function(mesi_timiPlith, tipiki_apokl, plithos, spaniotita) {
s <- tipiki_apokl/sqrt(plithos)
a <- spaniotita/2
t <- qt(a, plithos-1, lower.tail=F)
m1 <- mesi_timiPlith-t*s
m2 <- mesi_timiPlith+t*s
c(m1, m2)
}Γράφουμε, λοιπόν:
## [1] 1.032887 1.145937Βρίσκουμε λοιπόν ότι το 95% των συνηθισμένων φιλοδωρημάτων θα είναι ανάμεσα στα ποσά 1.03€ και 1.15€. Το 1.30€, λοιπόν, είναι ένα σπάνιο φιλοδώρημα, δηλαδή ένα φιλοδώρημα που κατά πάσα πιθανότητα δεν θα δινόταν, οπότε καταλαβαίνουμε ότι κάτι το ξεχωριστό συμβαίνει εκεί.
Είδαμε ότι το κόκκινο χρώμα ασκεί επίδραση στο μέγεθος του
φιλοδωρήματος. Πόσο μεγάλη είναι όμως αυτή; Αυτό το ερώτημα θα μας το
απαντήσει το d του Cohen (βλ. επίσης υποενότητα Μέγεθος επίδρασης). Η συνάρτηση που το
υπολογίζει είναι η d_cohen(🗡️🗡️🗡️, 💞💞💞, 👑👑👑),
όπου:
στη θέση του 🗡️🗡️🗡️ γράφουμε την μέση τιμή του
πληθυσμού (δηλαδή τα 1.089412€),
στη θέση του 💞💞💞 γράφουμε την τυπική απόκλιση
όλου του δείγματος (αυτή που βρήκαμε ότι είναι 0.3733317€, όχι την 0.46€
που αφορούσε τα κόκκινα μπλουζάκια) και
στη θέση του 👑👑👑 θα πάει το ποσοστό που θεωρούμε
ότι αντιπροσωπεύει τα σπάνια συμβάντα, το οποίο σε μας είναι το 5%,
δηλαδή το 0.05.
d_cohen <- function(mesi_timiDigm, tipiki_apoklPlith, mesi_timiPlith){
(mesi_timiDigm-mesi_timiPlith)/tipiki_apoklPlith
}Οπότε γράφοντας:
## [1] 0.5640775βρίσκουμε ότι αυτό είναι 0.5640775. Κι αυτό τι σημαίνει τώρα; Οι παρακάτω οδηγίες από εδώ θα μας δώσουν μια απάντηση:
αν το d του Cohen είναι 0 ή ±0.1, τότε το μέγεθος επίδρασης είναι ασήμαντο,
αν το d του Cohen είναι ±0.2, ±0.3 ή ±0.4, τότε το μέγεθος επίδρασης είναι μικρό,
αν το d του Cohen είναι ±0.5, ±0.6 ή ±0.7, τότε το μέγεθος επίδρασης είναι μέτριο,
αν το d του Cohen είναι ±0.8, ±0.9 κτλ, τότε το μέγεθος επίδρασης είναι μεγάλο,
Οπότε, αφού εμείς βρήκαμε 0.5640775, καταλαβαίνουμε ότι είναι μέτριο το μέγεθος της επίδρασης από το κόκκινο μπλουζάκι στο ύψος του φιλοδωρήματος.
Όλος ο κώδικας που χρησιμοποιήσαμε είναι ο κάτωθι:
# Υπολογισμός μέσης τιμής
m1 <- as.numeric(readline(prompt="Δώσε 1η μέση τιμή: "))
n1 <- as.numeric(readline(prompt="Δώσε 1ο πλήθος τιμών: "))
Sm <- m1*n1
Sn <- n1
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
while (test != 'Q') {
m_a <- as.numeric(readline(prompt="Δώσε επόμενη μέση τιμή: "))
n_a <- as.numeric(readline(prompt="Δώσε επόμενο πλήθος τιμών: "))
Sm <- m_a*n_a+Sm
Sn <- n_a+Sn
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
}
Sm/Sn
# Υπολογισμός τυπικής απόκλισης
m1 <- as.numeric(readline(prompt="Δώσε 1η μέση τιμή: "))
n1 <- as.numeric(readline(prompt="Δώσε 1ο πλήθος τιμών: "))
s1 <- as.numeric(readline(prompt="Δώσε 1η τυπική απόκλιση: "))
Sm <- m1*n1
Sn <- n1
Sq <- (s1^2)*(n1-1)+n1*m1^2
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
while (test != 'Q') {
m_a <- as.numeric(readline(prompt="Δώσε επόμενη μέση τιμή: "))
n_a <- as.numeric(readline(prompt="Δώσε επόμενο πλήθος τιμών: "))
s_a <- as.numeric(readline(prompt="Δώσε επόμενη τυπική απόκλιση: "))
Sm <- m_a*n_a+Sm
Sn <- n_a+Sn
Sq <- Sq+(s_a^2)*(n_a-1)+n_a*m_a^2
test <- readline(prompt="Σταματάμε τη διαδικασία; Γράψε 'Q' για 'ναι': ")
}
m <- Sm/Sn
m
sqrt((Sq-Sn*m^2)/(Sn-1))
# Εκτίμηση πληθυσμιακής μέσης τιμής
DiastEmpist <- function(mesi_timi, tipiki_apokl, plithos, pith) {
s <- tipiki_apokl/sqrt(plithos)
a <- (1-pith)/2
t <- qt(a, plithos-1, lower.tail=F)
m1 <- mesi_timi-t*s
m2 <- mesi_timi+t*s
c(m1, m2)
}
DiastEmpist(1.089412, 0.3733317, 170, 0.95)
# p-τιμή
p_timi <- function(mesi_timiDigm, tipiki_apoklPlith, mesi_timiPlith, plithos) {
a <- abs(mesi_timiDigm-mesi_timiPlith)
s <- tipiki_apoklPlith/sqrt(plithos)
2-2*pt(a/s, plithos-1)
}
p_timi(1.3, 0.3733317, 1.089412, 170)
# α-τιμή
a_timi <- function(mesi_timiPlith, tipiki_apokl, plithos, spaniotita) {
s <- tipiki_apokl/sqrt(plithos)
a <- spaniotita/2
t <- qt(a, plithos-1, lower.tail=F)
m1 <- mesi_timiPlith-t*s
m2 <- mesi_timiPlith+t*s
c(m1, m2)
}
a_timi(1.089412, 0.3733317, 170, 0.05)
# Μέγεθος επίδρασης
d_cohen <- function(mesi_timiDigm, tipiki_apoklPlith, mesi_timiPlith){
(mesi_timiDigm-mesi_timiPlith)/tipiki_apoklPlith
}
d_cohen(1.3, 0.3733317, 1.089412)