保護犬・保護猫・保護動物のデータ解析その3ー去勢避妊は譲渡に影響するか?ー





前回(保護犬・保護猫・保護動物のデータ解析その2)の続きです。

まずは、ライブラリとデータを読み込みます。

library(tidyverse)
library(reshape2)
df <- read.csv("C:\\Users\\shelter\\Austin_Animal_Center_Outcomes.csv")
colnames(df)
##  [1] "Animal.ID"        "Name"             "DateTime"         "MonthYear"       
##  [5] "Date.of.Birth"    "Outcome.Type"     "Outcome.Subtype"  "Animal.Type"     
##  [9] "Sex.upon.Outcome" "Age.upon.Outcome" "Breed"            "Color"
df$Outcome.Type <- ifelse(df$Outcome.Type=="Adoption","Yes","No")
dfdog <- df %>% filter(Animal.Type=="Dog")
dfcat <- df %>% filter(Animal.Type=="Cat")

犬の避妊去勢と、譲渡の関係を見ていきます。

dogsex <- dfdog %>% 
  select(Outcome.Type,Sex.upon.Outcome)

dogsex2 <- as.data.frame(table(sex=dogsex$Sex.upon.Outcome,
                               Adapt =dogsex$Outcome.Type))

dogsex2 <- dcast(dogsex2, sex~Adapt, id.var=Freq)
ggplot(dogsex2, aes(reorder(sex,Yes))) +
  geom_bar(aes(y=Yes,fill="Yes"),stat = "identity") +
  geom_bar(aes(y=-No,fill="No"),stat="identity") +
  scale_fill_manual("Adopted",values=c(Yes="pink",No="lightblue"))+
  xlab("")+
  ylab("")+
  coord_flip()+
  theme_minimal()

避妊去勢がされている犬は、譲渡成功する率が高い

避妊メスと去勢オスでは、統計的に比率に違いがあるのでしょうか。

Peason’s Chi-squared testを実施したいと思います。

head(dogsex2)
##             sex    No   Yes
## 1 Intact Female  6647   446
## 2   Intact Male  7739   416
## 3 Neutered Male 12656 16365
## 4          NULL     2     0
## 5 Spayed Female  9393 15446
## 6       Unknown   448     2

Neutered Male No:12656(56%) Yes:16365(44%)

Spayed Female No:9393(38%) Yes:15446(62%)

x <- matrix(c(12656,16365,9393,15446),nrow=2,ncol=2)
x
##       [,1]  [,2]
## [1,] 12656  9393
## [2,] 16365 15446
chisq.test(x)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  x
## X-squared = 185.6, df = 1, p-value < 2.2e-16

p-value<0.05なので、5%水準で有意な差がありました。

犬は、避妊メスのほうが去勢オスより譲渡成功率が高い

猫ではどうでしょうか。

catsex <- dfcat %>% 
  select(Outcome.Type,Sex.upon.Outcome)

catsex2 <- as.data.frame(table(sex=catsex$Sex.upon.Outcome,
                               Adapt =catsex$Outcome.Type))

catsex2 <- dcast(catsex2, sex~Adapt, id.var=Freq)
ggplot(catsex2, aes(reorder(sex,Yes))) +
  geom_bar(aes(y=Yes,fill="Yes"),stat = "identity") +
  geom_bar(aes(y=-No,fill="No"),stat="identity") +
  scale_fill_manual("Adopted",values=c(Yes="pink",No="lightblue"))+
  xlab("")+
  ylab("")+
  coord_flip()+
  theme_minimal()

猫でも避妊去勢しているほうが、譲渡成功しやすい

避妊メス去勢オスの差はあるでしょうか。

Neutered Male: No 4112(30%) Yes 9756(70%)

Spayed Female: No 3630(26%) Yes 10125(74%)

x <- matrix(c(4112,9756,3630,10125),nrow=2,ncol=2)
chisq.test(x)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  x
## X-squared = 36.234, df = 1, p-value = 1.75e-09

有意水準5%で、差がありました。

犬と猫で、譲渡成功率に差があるのでしょうか。

ggplotのbarチャートを使いたいのですが、そのためにreshape2でデータの形を変えます。 Wide to long : melt(data, id.vars = c( “残す列1“ ,”残る列2” ) ) Long to wide: dcast(data, 残す列1+残る列2~くずす列, value.var = “ くずした下のデータ “)

x1 <- sum(dogsex2$No)
x2 <- sum(dogsex2$Yes)
x3 <- sum(catsex2$No)
x4 <- sum(catsex2$Yes)

dc <- data.frame(matrix(c(x1,x2,x3,x4,"No","Yes"),nrow=2,ncol=3))
colnames(dc) <- c("Dog", "Cat","Adopted")
dc <- melt(dc,id.vars=c("Adopted"))
colnames(dc) <- c("Adopted", "Animal","number")

ggplot(dc)+
  geom_bar(aes(x=Animal,y=number,fill=Adopted),
           ,position="stack",
           stat="identity")

barchartのy軸がおかしいです。

meltで形変えたら、numberがcharactorになっていました。

再挑戦。

dc$number <- as.numeric(dc$number)

ggplot(dc)+
  geom_bar(aes(x=Animal,y=number,fill=Adopted),
           ,position="stack",
           stat="identity")+
  scale_fill_manual("Adopted",values=c(Yes="pink",No="lightblue"))

barchartの割合を表示させたいです。position=“fill”を使います。

ggplot(dc)+
  geom_bar(aes(x=Animal,y=number,fill=Adopted),
           ,position="fill",
           stat="identity") +
  scale_fill_manual("Adopted",values=c(Yes="pink",No="lightblue"))

y軸をパーセントにしたいです。scale_y_continuous(labels = scales::percent)を入れます。

ggplot(dc)+
  geom_bar(aes(x=Animal,y=number,fill=Adopted),
           ,position="fill",
           stat="identity") +
  scale_fill_manual("Adopted",values=c(Yes="pink",No="lightblue"))+
  scale_y_continuous(labels = scales::percent)

グラフ的には、犬と猫の譲渡成約率にはあまり違いはなさそうだけど、統計テストをすると違いはでるでしょうか。

x <- matrix(c(x1,x2,x3,x4),nrow=2,ncol=2)
chisq.test(x)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  x
## X-squared = 26.485, df = 1, p-value = 2.655e-07

p-value = 1.75e-09なので、有意水準5%で差がありました。うーん。サンプル数が多いから、統計的に差が出てしまっているのではないかと思います。

次回に続きます。


Categories:

category