5 курс / ОЗИЗО Общественное здоровье и здравоохранение / Статистический_анализ_данных_в_медицинских_исследованиях_в_2_ч_Красько

Приложение R-6

library(PropCIs)

# Пример 1 EE=25 EN=125 CE=100 CN=100

OR=(EE/EN)/(CE/CN)

CIOR <- orscoreci(EE,EE+EN,CE,CE+CN, conf.level=0.95)

cat("Отношение шансов: ", OR,"; 95% ДИ ", CIOR$conf.int[1]," – ",CIOR$conf.int[2], "\n")

EER=EE/(EE+EN)

CER=CE/(CE+CN)

RR=EER/CER

CIRR <- riskscoreci (EE,EE+EN,CE,CE+CN, conf.level=0.95)

cat("Относительный риск: ", RR,"; 95% ДИ ", CIRR$conf.int[1]," – ",CIRR$conf.int[2], "\n")

# Пример 2 EE=125 EN=25 CE=100 CN=100

OR=(EE/EN)/(CE/CN)

CIOR <- orscoreci(EE,EE+EN,CE,CE+CN, conf.level=0.95)

cat("Отношение шансов: ", OR,"; 95% ДИ ", CIOR$conf.int[1]," – ",CIOR$conf.int[2], "\n")

EER=EE/(EE+EN)

CER=CE/(CE+CN)

RR=EER/CER

CIRR <- riskscoreci (EE,EE+EN,CE,CE+CN, conf.level=0.95)

cat("Относительный риск: ", RR,"; 95% ДИ ", CIRR$conf.int[1]," – ",CIRR$conf.int[2], "\n")

251

Приложение R-7

#Пример расчета клинического исследования двух препаратов

EE=10

EN=2

CE=4

CN=8

DifP=EE/(EE+EN)-CE/(CE+CN)

DCI <- diffscoreci(EE,EE+EN,CE,CE+CN,conf.level=0.95)

cat("Разность в пропорциях: ", DifP,"; 95% ДИ: ", DCI$conf.int[1]," – ",DCI$conf.int[2], "\n")

OR=(EE/EN)/(CE/CN)

CIOR <- orscoreci(EE,EE+EN,CE,CE+CN, conf.level=0.95)

cat("Отношение шансов: ", OR,"; 95% ДИ: ", CIOR$conf.int[1]," – ",CIOR$conf.int[2], "\n")

252

Приложение R-8

# построение ROC-кривой

library(pROC)

ls <- c(1.0, 1.1, 1.3, 1.5, 2.8, 3.7, 4.6, 4.8, 4.9, 5.5, 5.5, 5.9) response <- c(1,0,1,1,0,1,0,0,1,0,0,0)

roc.data <-roc(response , ls,ci=T) print(roc.data) #ci.auc(roc.data)

plot.roc(roc.data,print.thres='best',print.auc=TRUE, grid=TRUE, family="mono") plot.roc(smooth(roc.data), add=TRUE, col="blue")

ci.thresholds(roc.data,boot.n=200, conf.level=0.95, stratified=FALSE,thresholds='best')

253

Приложение R-9

library(abind, pos=4) library(vcd) library(lattice)

######################################

# три локализации

######################################

MS <- matrix(c(54,57,14,14,33,1), 2, 3, byrow=TRUE) rownames(MS) <- c('Наличие', 'Отсутствие') colnames(MS) <- c('I', 'II', 'III')

names(dimnames(MS)) <- c("Metastasis","Localization") MS # печать таблицы

colPercents(MS) # проценты

TestChiq <- chisq.test(MS, correct=FALSE) # хи-квадрат тест

round(TestChiq$expected, 2) round(TestChiq$stdres, 2) TestChiq

remove(TestChiq)

# создание мозаичной диаграммы рис. 14-1 trellis.device(theme="col.whitebg", family="mono")

#параметры легенды мозаичной диаграммы

q<- legend_resbased(fontsize = 10,

x = unit(1, "lines"), y = unit(0.1,"npc"),

height = unit(0.8, "npc"), width = unit(0.7, "lines"), digits = 3, check_overlap = TRUE, text = NULL,

steps = 200, ticks = 10, pvalue = TRUE, range = NULL)

#параметры мозаичной диаграммы

gg <- shading_hcl(MS, residuals = NULL, expected = NULL, df = 2, h = NULL, c = NULL, l = NULL, interpolate = c(1.5, 2), lty = 1, eps = NULL, line_col = "black", p.value = NULL, level = 0.95)

# получение рисунка

assoc(MS, shade=T, xscale=0.5,margins=c(5,4,4,5),legend = q,gp = gg, ,xlab="", main = "", labeling_args = list(1,2))

remove(MS)

#сравнение II и I metastasis <- c( 57, 54 ) all <- c( 90, 68)

prop.test(metastasis, all, alternative='less', conf.level=.95, correct=FALSE)

#сравнение II и III

metastasis <- c( 57, 14 ) all <- c( 90, 15)

prop.test(metastasis, all, alternative='less', conf.level=.95, correct=FALSE)

# сравнение II и не-II metastasis <- c( 68, 57 ) all <- c(83, 90)

prop.test(metastasis, all, alternative='two.sided', conf.level=.95, correct=FALSE)

254

# доверительные интервалы для II и не-II групп prop.test(57, 90)

prop.test(68, 83)

#Разность в пропорциях metastasis <- c( 68, 57 ) all <- c(83, 90)

t <- prop.test(metastasis, all, alternative='two.sided', conf.level=.95, correct=FALSE)

cat("разность в пропоциях=",t$estimate[1]-t$estimate[2], ", 95% ДИ", t$conf.int[1], " - ", t$conf.int[2],"\n")

#оценка пропорций и разницы в пропоциях

#с помощью библиотеки epiR

library(epiR)

round(epi.conf(matrix(c(68, 15),ncol = 2), ctype = "prop.single"), digits = 3) round(epi.conf(matrix(c(57, 33),ncol = 2), ctype = "prop.single"), digits = 3)

dat <- matrix(c(68, 15, 57, 33),ncol = 4) round(epi.conf(dat, ctype = "prop.unpaired"), digits = 3)

# оценка отношения шансов

MS.2_not2 <- matrix(c(68,15,57,33), 2, 2) rownames(MS.2_not2) <- c('Наличие', 'Отсутствие') colnames(MS.2_not2) <- c('не II', ' II')

MS.2_not2 fisher.test(MS.2_not2)

# оценка относительного риска library(PropCIs)

RR=(68/83)/(57/90)

t <- riskscoreci(68, 83, 57, 90, conf.level=0.95)

cat("относительный риск RR=",RR, ", 95% ДИ", t$conf.int[1], " - ", t$conf.int[2],"\n")

255

Приложение R-10

Исходные данные

256

257

Скрипт R для выполнения анализа

Перед выполнением необходимо скопировать данные, сохранить в текстовом файле или файле EXCEL и импортировать их в набор данных R под именем Markers.

library(abind)

library(nortest)

library(abind)

library(e1071)

library(class)

library(lattice)

library(grid)

library(colorspace)

library(effects)

library(car)

library(effects)

Markers$Group <- factor(Markers$Group, levels=c('control','LowDose','HighDose'))

##############################################

#Наблюдения по полу и объему лечения

#Таблица 16-5

xtabs(~Group + Sex, data=Markers)

##################################################################################

# BCTX

########################################################################

#Шаг 1 предварительные исследования зависимой переменной

########################################################################

#выделение контрольной группы

control.BCTX <- subset(Markers, subset=Group=="control", select=c(BCTX))

#проверка на соответствие закону нормального распределения shapiro.test(control.BCTX$BCTX)

sf.test(control.BCTX$BCTX)

#выделение группы под воздействием

treat.BCTX <- subset(Markers, subset=Group!="control", select=c(BCTX))

# проверка на соответствие закону нормального распределения

shapiro.test(treat.BCTX$BCTX) sf.test(treat.BCTX$BCTX)

# проверка на соответствие закону нормального распределения всей выборки

shapiro.test(Markers$BCTX) sf.test(Markers$BCTX) par(family='mono') plot(density (Markers$BCTX))

# Графики Рис.16-8, Рис.16-9 trellis.device(theme="col.whitebg", family="mono")

scatterplot(BCTX~age.at.measure | Sex, reg.line=FALSE, smooth=TRUE, spread=F, boxplots='xy', cex.axis=0.8, span=0.5, jitter=list(x=1, y=1), by.groups=TRUE, data=Markers)

258

scatterplot(BCTX~age.at.measure | Group, reg.line=FALSE, smooth=TRUE, spread=F, boxplots='xy', cex.axis=0.8, span=0.5, jitter=list(x=1, y=1), by.groups=TRUE, data=Markers)

# создание бинарного предиктора контроль-лечение

Markers$Expose <- with(Markers, 1*(Group!='control')) Markers$Expose <- factor(Markers$Expose, labels=c('control','expose'))

scatterplot(BCTX~age.at.measure | Expose, reg.line=FALSE, smooth=TRUE, spread=F, boxplots='xy', cex.axis=0.8, span=0.5, jitter=list(x=1, y=1), by.groups=TRUE, data=Markers)

# группы возраста

numSummary(Markers[,"age.at.measure"], statistics=c("mean", "sd", "quantiles"),quantiles=c(0,.25,.5,.75,1))

Markers$Age.Group <- with(Markers, 1*(age.at.measure<10)+ 2*(age.at.measure>=10 & age.at.measure<15)+3*(age.at.measure>=15 & age.at.measure<=18)+4*(age.at.measure>18)) Markers$Age.Group <- factor(Markers$Age.Group, labels=c('до 10','10-14','15-18','18+'))

# Таблица 16-6

.Table <- xtabs(~Age.Group+Sex, data=Markers)

.Table

chisq.test(.Table, correct=FALSE)

#проверка на различие возраста в группа, множественное сравнение

TukeyHSD(aov(age.at.measure ~ Age.Group*Sex, data=Markers))

#Таблица 16-7

.Table <- xtabs(~Age.Group+Expose, data=Markers)

.Table

chisq.test(.Table, correct=FALSE) remove(.Table)

##################################

# Шаг 2 предварительная модель #

##################################

#предварительная модель с основными эффектами

LM.0 <- lm(BCTX ~ Age.Group+Group+Sex, data=Markers)

#Таблица 16-8 Anova(LM.0, test="F")

#Таблица 16-9 summary(LM.0)

########################################################################

#Шаг 3 провека линейной гипотезы о равенстве коэффициентов регрессии

#снижение количества параметров модели, сравнение моделей

########################################################################

#проверка линейной гипотезы о различимом воздействии выскокодозного и низкодозного воздействия linearHypothesis(LM.0, "Group[T.HighDose] - Group[T.LowDose] = 0")

#проверка линейной гипотезы о различии возрастных групп до 14 и 10-14

linearHypothesis(LM.0, "Age.Group[T.10-14] = 0")

# сокращение возрастных групп

Markers$Age.Group.BCTX <- with(Markers, 1*(age.at.measure<15)+2*(age.at.measure>=15 & age.at.measure<=18)+3*(age.at.measure>18))

259

Markers$Age.Group.BCTX <- factor(Markers$Age.Group.BCTX, labels=c('до 15','15-18','18+'))

#предварительная модель с основными эффектами

LM.1 <- lm(BCTX ~ Age.Group.BCTX+Expose+Sex, data=Markers)

#Таблица 16-10 Anova(LM.1, test="F")

# сравнение моделей anova(LM.0, LM.1, test="F")

##################################################

# Шаг 4 провека наличия эффектов взаимодействия

##################################################

LM.interaction <- stepAIC(LM.1, ~ .^2 ,direction='both', k=2,trace =T )

#Таблица 16-11 Anova(LM.interaction, test="F")

#Таблица 16-12 summary(LM.interaction)

#проверка линейной гипотезы

linearHypothesis(LM.interaction, "Expose[T.expose] + Age.Group.BCTX[T.18+]:Expose[T.expose] = 0")

##############################################

#Шаг 5 исследование остатков и выбросов

##############################################

#основные графики для исследования остатков Рис. 16-10 oldpar <- par(oma=c(0,0,3,0), mfrow=c(1,2),family='mono') plot(LM.interaction,sub.caption = "LM.interaction", which=c(1,2)) par(oldpar)

#проверка остатков

res.LM.interaction <- residuals(LM.interaction) shapiro.test(res.LM.interaction) sf.test(res.LM.interaction)

#тест на выбросы outlierTest(LM.interaction, cutoff=Inf)

#График Рис 16-11

influencePlot(LM.interaction, id.method="identify")

# влияющие наблюдения

inflm <- influence.measures(LM.interaction) summary(inflm)

##########################################################

# удаление выброса и повторение шагов подгонки модели

##########################################################

Markers.New <- Markers[-c(84),]

# Повтороение подгонки модлеи

LM.prem <- lm(BCTX ~ Age.Group+Group+Sex, data=Markers.New)

260