/**
* jQuery Plugin: Sticky Tabs
*
* @author Aidan Lister
* adapted by Ruben Arslan to activate parent tabs too
* http://www.aidanlister.com/2014/03/persisting-the-tab-state-in-bootstrap/
*/
(function($) {
"use strict";
$.fn.rmarkdownStickyTabs = function() {
var context = this;
// Show the tab corresponding with the hash in the URL, or the first tab
var showStuffFromHash = function() {
var hash = window.location.hash;
var selector = hash ? 'a[href="' + hash + '"]' : 'li.active > a';
var $selector = $(selector, context);
if($selector.data('toggle') === "tab") {
$selector.tab('show');
// walk up the ancestors of this element, show any hidden tabs
$selector.parents('.section.tabset').each(function(i, elm) {
var link = $('a[href="#' + $(elm).attr('id') + '"]');
if(link.data('toggle') === "tab") {
link.tab("show");
}
});
}
};
// Set the correct tab when the page loads
showStuffFromHash(context);
// Set the correct tab when a user uses their back/forward button
$(window).on('hashchange', function() {
showStuffFromHash(context);
});
// Change the URL when tabs are clicked
$('a', context).on('click', function(e) {
history.pushState(null, null, this.href);
showStuffFromHash(context);
});
return this;
};
}(jQuery));
window.buildTabsets = function(tocID) {
// build a tabset from a section div with the .tabset class
function buildTabset(tabset) {
// check for fade and pills options
var fade = tabset.hasClass("tabset-fade");
var pills = tabset.hasClass("tabset-pills");
var navClass = pills ? "nav-pills" : "nav-tabs";
// determine the heading level of the tabset and tabs
var match = tabset.attr('class').match(/level(\d) /);
if (match === null)
return;
var tabsetLevel = Number(match[1]);
var tabLevel = tabsetLevel + 1;
// find all subheadings immediately below
var tabs = tabset.find("div.section.level" + tabLevel);
if (!tabs.length)
return;
// create tablist and tab-content elements
var tabList = $('
');
$(tabs[0]).before(tabList);
var tabContent = $('
');
$(tabs[0]).before(tabContent);
// build the tabset
var activeTab = 0;
tabs.each(function(i) {
// get the tab div
var tab = $(tabs[i]);
// get the id then sanitize it for use with bootstrap tabs
var id = tab.attr('id');
// see if this is marked as the active tab
if (tab.hasClass('active'))
activeTab = i;
// remove any table of contents entries associated with
// this ID (since we'll be removing the heading element)
$("div#" + tocID + " li a[href='#" + id + "']").parent().remove();
// sanitize the id for use with bootstrap tabs
id = id.replace(/[.\/?&!#<>]/g, '').replace(/\s/g, '_');
tab.attr('id', id);
// get the heading element within it, grab it's text, then remove it
var heading = tab.find('h' + tabLevel + ':first');
var headingText = heading.html();
heading.remove();
// build and append the tab list item
var a = $('' + headingText + '');
a.attr('href', '#' + id);
a.attr('aria-controls', id);
var li = $('
');
li.append(a);
tabList.append(li);
// set it's attributes
tab.attr('role', 'tabpanel');
tab.addClass('tab-pane');
tab.addClass('tabbed-pane');
if (fade)
tab.addClass('fade');
// move it into the tab content div
tab.detach().appendTo(tabContent);
});
// set active tab
$(tabList.children('li')[activeTab]).addClass('active');
var active = $(tabContent.children('div.section')[activeTab]);
active.addClass('active');
if (fade)
active.addClass('in');
if (tabset.hasClass("tabset-sticky"))
tabset.rmarkdownStickyTabs();
}
// convert section divs with the .tabset class to tabsets
var tabsets = $("div.section.tabset");
tabsets.each(function(i) {
buildTabset($(tabsets[i]));
});
};
保護犬・保護猫・保護動物のデータ解析その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%で差がありました。うーん。サンプル数が多いから、統計的に差が出てしまっているのではないかと思います。
次回に続きます。
// add bootstrap table styles to pandoc tables
function bootstrapStylePandocTables() {
$('tr.odd').parent('tbody').parent('table').addClass('table table-condensed');
}
$(document).ready(function () {
bootstrapStylePandocTables();
});