INTRODUCTION:

Data has been chosen from https://healthdata.gov/dataset/assisted-reproductive-technology-art-surveillance. In 1996, CDC initiated the ART Surveillance System to collect cycle specific and clinic specific data from all medical clinics practicing ART (assisted reproductive technology) in the United States and its territories. The data collected include patient’s diagnosis, type of ART, clinical information pertaining to the ART procedure, and information on pregnancy outcomes. ART includes all fertility treatments in which either eggs or embryos are handled. The main type of ART is in vitro fertilization (IVF). IVF involves extracting a woman’s eggs, fertilizing the eggs in the laboratory, and then transferring the resulting embryos into the woman’s uterus through the cervix. ART success rates vary in the context of patient and treatment characteristics, such as age, infertility diagnosis, number of embryos transferred, type of ART procedure, and history of previous births, miscarriages. Though field is very vast but here I am only interested in number of transfers of fresh embryos, its outcomes through IVF (in vitro fertilization) and what are infertility factors, either female or male. I have choose few fertility clinics of New York and studied success rate in terms of live births of babies through IVF.

knitr::include_graphics("/Users/kanwallatif/Documents/IVF.png")

Packages used in Analysis:

library(readr)
library(dplyr)
library(magrittr)
library(tidyr)
library(texreg)
library(ggplot2)
library(ggthemes)
library(ggrepel)
library(tidyverse)
library(viridis)
library(knitr)
library(kableExtra)
library(ggridges)
library(visreg)
library(reshape2)
library(treemapify)
IVF<-read_csv("/Users/kanwallatif/Documents/IVFDataset3.csv", col_names = TRUE) # Importing dataset file.

Selected Number of IVF Centers in New York:

length(unique(IVF$clinic_name)) %>%
kable(col.names = c("IVF Clinics"))%>%
  kable_styling("striped",full_width=F)%>%
  row_spec(0)
IVF Clinics
23

Overall IVF Success %age resulting to births:

  summarise(IVF,Overall_Success_rate=mean(IVF_Success_Rate)) %>%
kable(col.names = c("IVF Success %age"))%>%
  kable_styling("striped",full_width=F)%>%
  row_spec(0)
IVF Success %age
0.2469565 
knitr::include_graphics("/Users/kanwallatif/Documents/NewBorn.png")

INTERPRETATION:
Overall for 23 fertility clinics have 24.6% IVF success rate in terms of live births for fresh embryo transfer. Embryo are eggs, fertilized by sperm in the lab for 3-5 days and transferred into the woman’s uterus through the cervix.

IVF Success %age of each Clinic resulting to births:

IVF %>%
  group_by (clinic_name) %>%
  summarize(mean_Success_rate=mean(IVF_Success_Rate)) %>%
  kable(col.names = c("Clinic names","Mean IVF Success rate"))%>%
  kable_styling("striped",full_width=F)%>%
  row_spec(0)
Clinic names Mean IVF Success rate
CENTER FOR HUMAN REPRODUCTION (CHR) 0.21
CNY FERTILITY CENTER 0.29
COLUMBIA UNIVERSITY CENTER FOR WOMEN’S REPRODUCTIVE CARE 0.18
GENESIS FERTILITY & REPRODUCTIVE MEDICINE 0.22
GOLD COAST IVF 0.29
HUDSON VALLEY FERTILITY, PLLC 0.15
ISLAND REPRODUCTIVE SERVICES, PC 0.27
KOFINAS FERTILITY GROUP 0.29
LIBERA MEDICAL, PLLC 0.24
LONG ISLAND IVF 0.32
MONTEFIORE’S INSTITUTE FOR REPRODUCTIVE MEDICINE AND HEALTH 0.23
NEW HOPE FERTILITY CENTER 0.21
NEW YORK REPRODUCTIVE WELLNESS 0.24
NEWAY MEDICAL 0.23
NOBLE FERTILITY CENTER 0.18
NORTHWELL HEALTH FERTILITY 0.20
NYU LANGONE FERTILITY CENTER 0.28
REPRODUCTIVE MEDICINE ASSOCIATES OF NEW YORK, LLP 0.29
REPRODUCTIVE SPECIALISTS OF NEW YORK 0.39
STRONG FERTILITY CENTER 0.28
THE NEW YORK FERTILITY CENTER 0.12
WEILL CORNELL MEDICINE 0.36
WESTCHESTER FERTILITY AND REPRODUCTIVE ENDOCRINOLOGY 0.21

INTERPRETATION:
The highest IVF success rate among selected clinics is 39% for Reproductive Specialists of New York then comes Weill Cornell Medicine, 36% and lowest IVF success rate is observed 12%.

Visualization:

IVF1=IVF%>%
  select(clinic_name,IVF_Success_Rate)%>%
  group_by(IVF_Success_Rate)%>%
  mutate(mean_IVF_Suc=mean(IVF_Success_Rate))%>%
  select(clinic_name,mean_IVF_Suc)%>%
  unique()

ggplot(data=IVF1,aes(x=reorder(clinic_name,mean_IVF_Suc),y=mean_IVF_Suc,fill=mean_IVF_Suc))+geom_bar(stat = "identity")+scale_fill_viridis(name = "IVF Success", option = "C")+coord_flip()+labs(title = 'IVF Success',subtitle='By Clinic',x="Clinic Names",y=" IVF Success")+geom_text(aes(label=round(mean_IVF_Suc,digits=3)), color="black", size=2.5,hjust=-.3)+
  theme_minimal()

Overall Females Infertility %age:

  summarise(IVF,Overall_Success_rate=mean(Female_Diagnosis)) %>%
kable(col.names = c("Female Infertility %age"))%>%
  kable_styling("striped",full_width=F)%>%
  row_spec(0)
Female Infertility %age
0.1634783

INTERPRETATION:
Female infertility percentage reported to selected clinics is 16.3% opting for IVF process.

Overall Male Infertility %age:

  summarise(IVF,Overall_Success_rate=mean(Male_Diagnosis)) %>%
kable(col.names = c("Male Infertility %age"))%>%
  kable_styling("striped",full_width=F)%>%
  row_spec(0)
Male Infertility %age
0.2678261

INTERPRETATION:
As compared to females males have higher infertility rate i.e 26.7%.

Grouping of Diagnosis contribution to female Infertilily:

NewDataIVF=melt(IVF, measure.vars=c("Diag_TubalRate","Diag_OvulatoryRate", "Diag_DORRate", "Diag_EndometriosisRate", "Diag_EndometriosisRate", "Diag_UterineRate" ),variable.name = "Female_Infertility_Diagnosis",value.name = "Female_Infertility_Diagnosis_Rate")

NewDataIVF=melt(NewDataIVF, measure.vars=c("Female_Diagnosis","Male_Diagnosis", "Other_Diagnosis"),variable.name = "M.F.O_Infertility_Diagnosis",value.name = "Overall_Infertility_Diagnosis_Rate")

NewDataIVF=melt(NewDataIVF, measure.vars=c("Total_Fresh_Transfer","IVF_Success_Rate"),variable.name = "IVF_Transfer_Results",value.name = "IVF_Transfer_Results_Rate")

D1 <- as.data.frame(table(NewDataIVF$Female_Infertility_Diagnosis))
D2 <- head(arrange(D1, desc (Freq)), n= 6)
D3 <- rename(D2, Diagnosis = Var1)
D4 <-ggplot(D3, aes(fill = Diagnosis, area = Freq, label= Diagnosis)) + geom_treemap() + geom_treemap_text(colour= "white", place = "centre", grow= TRUE) + labs(title = "Female Infertility Diagnosis")
D4

NewDataIVF1=NewDataIVF%>%
  select(Female_Infertility_Diagnosis,Female_Infertility_Diagnosis_Rate)%>%
  group_by(Female_Infertility_Diagnosis,Female_Infertility_Diagnosis_Rate)%>%
  mutate(avgFemale_Infertility=mean(Female_Infertility_Diagnosis_Rate))%>%
  select(Female_Infertility_Diagnosis,avgFemale_Infertility)%>%
  unique()

ggplot(NewDataIVF1, aes(x = `avgFemale_Infertility`, y = `Female_Infertility_Diagnosis`, fill = ..x..)) +
  geom_density_ridges_gradient(scale = 3, rel_min_height = 0.05, gradient_lwd = 1.) +
  scale_x_continuous(expand = c(0.01, 0)) +
  scale_y_discrete(expand = c(0.01, 0)) +
  scale_fill_viridis(name = "Average Female Infertility", option = "Z") +
  labs(
    title = 'Average Female Infertility Diagnosis opting for IVF',
    subtitle = 'Average Female Infertility'
  ) +
  theme_ridges(font_size = 11, grid = TRUE)+xlab("Female Infertility")

INTERPRETATION:
In the above pattern emerging visual, it looks like there is a clear grouping of female fertility issues between Uterine and Endometriosis since endometriosis is tissue that normally lines the inside of uterus and grouping between Ovulatory and Tubal, is the fallopian tubes. To me at least, I can see that Uterine and Endometriosis have higher average fertility issues than the other diagnosis.

Comparison of Male , Female and other Infertility Diagnosis:

ggplot(data=NewDataIVF,aes(x=M.F.O_Infertility_Diagnosis,y=Overall_Infertility_Diagnosis_Rate))+geom_bar(stat="identity", fill = "#008B8B")+labs(title="Infertility Diagnosis",subtitle = "Infertility by male, females, others",x="Diagnosis",y="Percentage")+theme_ridges()

INTERPRETATION:
From the above graph it is clear that males have more infertility diagnosis as compared to females and then comes other reasons.

Looking at Infertility in Males & Females and IVF Success Rate:

NewDataIVF %>%
ggplot()+
        geom_violin(aes(x=M.F.O_Infertility_Diagnosis, y=Overall_Infertility_Diagnosis_Rate, group=M.F.O_Infertility_Diagnosis, fill=IVF_Transfer_Results_Rate, colour = "#68228B"))

INTERPRETATION:
It is very much clear that males have higher infertility rate more than 50% and have low IVF success rate compared to females and other infertility diagnosis, below 30%. As we can see more bulging areas for females and other diagnosis representing higher IVF success rates resulting to live births through fresh Embryo transfer.

Overall Comparison between Transfers of Embryos and IVF success Rate resulting in Baby Births:

library(ggplot2)
ggplot(data=NewDataIVF)+
geom_col(aes(x=IVF_Transfer_Results, y=IVF_Transfer_Results_Rate, fill=M.F.O_Infertility_Diagnosis), position="dodge")+labs(title="Number of Transfers for fresh Embryos and Live Birth Results",y="Success Rate")

INTERPRETATION:
The overall IVF success rate resulting to babies for fresh embryo transfer is less than 10%

Regression Models:

l1<-lm(IVF_Success_Rate~Diag_TubalRate, data=IVF)
l2<-lm(IVF_Success_Rate~Diag_TubalRate+ Diag_OvulatoryRate, data=IVF)
l3<-lm(IVF_Success_Rate~Diag_TubalRate+ Diag_OvulatoryRate+ Diag_UterineRate, data=IVF)
l4<-lm(IVF_Success_Rate~Diag_TubalRate*Diag_OvulatoryRate+Male_Diagnosis+ Diag_UterineRate, data=IVF)
l5<-lm(IVF_Success_Rate~Diag_TubalRate*Diag_OvulatoryRate+Male_Diagnosis+ Diag_UterineRate+ Diag_EndometriosisRate+Other_Diagnosis, data=IVF)
htmlreg(list(l1,l2,l3,l4,l5))
Statistical models
Model 1 Model 2 Model 3 Model 4 Model 5
(Intercept) 0.25*** 0.28*** 0.29*** 0.23* 0.27*
(0.02) (0.03) (0.03) (0.08) (0.10)
Diag_TubalRate -0.02 0.02 0.17 0.32 -0.01
(0.12) (0.11) (0.15) (0.44) (0.54)
Diag_OvulatoryRate -0.28 -0.27 -0.00 -0.45
(0.17) (0.17) (0.70) (0.83)
Diag_UterineRate -0.46 -0.30 -0.46
(0.33) (0.38) (0.42)
Male_Diagnosis 0.09 0.14
(0.16) (0.18)
Diag_TubalRate:Diag_OvulatoryRate -1.57 0.87
(3.26) (4.00)
Diag_EndometriosisRate 0.29
(0.26)
Other_Diagnosis -0.05
(0.49)
R2 0.00 0.11 0.19 0.23 0.29
Adj. R2 -0.05 0.02 0.07 0.01 -0.04
Num. obs. 23 23 23 23 23
RMSE 0.07 0.06 0.06 0.06 0.07
p < 0.001, p < 0.01, p < 0.05

INTERPRETATION:
At model 5, I can see that an increases in Tubal rate, ovulatory rate, uterine rate and other diagnosis increase can decreases the IVF success rate.

library(visreg)
visreg(l5, "Diag_OvulatoryRate", scale = "response", line=list(col="dark green"),fill=list(col="light pink"),
       xlab="Ovulatory Rate") +  theme_bw()
## Conditions used in construction of plot
## Diag_TubalRate: 0.14
## Male_Diagnosis: 0.27
## Diag_UterineRate: 0.06
## Diag_EndometriosisRate: 0.05
## Other_Diagnosis: 0.14

## NULL

INTERPRETATION:
As Ovulatory rate increases, IVF success rate resulting to birth decreases.

Visuals:

library(visreg)
visreg(l5, "Diag_UterineRate", scale = "response", line=list(col="dark green"),fill=list(col="light pink"),
       xlab="Uterine Rate") +  theme_bw()
## Conditions used in construction of plot
## Diag_TubalRate: 0.14
## Diag_OvulatoryRate: 0.11
## Male_Diagnosis: 0.27
## Diag_EndometriosisRate: 0.05
## Other_Diagnosis: 0.14

## NULL

INTERPRETATION:
As Uterine rate increases, IVF success rate resulting to birth decreases.

ggplot(NewDataIVF) +
  aes(x = Overall_Infertility_Diagnosis_Rate) +
  aes(y = IVF_Transfer_Results_Rate ) +
  facet_wrap(~ M.F.O_Infertility_Diagnosis, scales = "free_y", nrow = 2) +
  geom_smooth(col = "blue")+
  ylab("Embryo Transfer & Success")+
  xlab( "Infertility Rate ") +
  labs(title = "Embryo Transfer & IVF Success Rate for Infertility groups")+
  theme_bw(base_size = 13)

INTERPRETATION:
Though males have more infertility diagnosis rate but resulting to IVF success rate is more than females, i.e 6% , female diagnosis resulting to IVF success rate is 5% and other reasons have 6.5% IVF success rate.

CONCLUSION:

It has been seen from above analysis that overall IVF success rate resulting to live births are very low as compared to transfer of embryos and males infertility diagnosis are higher than females. Though chances are not that favourable and IVF process involve financial aspecst as well as emotional but it worth to enjoy a motherhood.

knitr::include_graphics("/Users/kanwallatif/Documents/Motherhood.png")