inst/shiny/global.R
In Ibrahimhassan94/MAAS: Meta-analysis with R via shiny
# usethis::edit_r_environ()
# auth0::use_auth0()
options(shiny.port = 8080)
# packages call ----
# library(shiny)
# # library(shinyjs)
# library(colourpicker)
# library(DT)
# library(meta)
# library(metafor)
# library(tools)
# library(readxl)
# library(stringr)
# library(poibin)
# library(gridExtra)
# library(ggplot2)
# library(ggrepel)
# library(fpc)
# library(mclust)
# library(shinyFeedback)
# library(shinymanager)
# library(auth0)
# library(htmlTable)
# library(kableExtra)
# library(knitr)
gtdata <- function(a) {
SMD <- {
SMD <- metafor::dat.normand1999
colnames(SMD) <- c("Study","source",'n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c')
SMD
}
OR <- {
library(meta)
data('Olkin95')
OR <- Olkin95
colnames(OR) <- c('Study','year','event.e','n.e','event.c','n.c')
OR
}
Inc2 <- {
data('smoking')
# data('lungcancer')
Inc2 <- smoking
colnames(Inc2) <- c('studlab','total','event.e', 'time.e', 'event.c', 'time.c')
Inc2
}
Inc1 <- {
Inc1 <- Inc2[,c(1,3,4)]
colnames(Inc2) <- c('studlab','event','time')
Inc1
}
Mean <- {
{data.frame(
Study=c('1','2','3','4','5','6','7','8','9','10','11','12'),
Country=c('US','Nigeria','Saudi Arabia','Iraq','Jordan','brazil','united states','Saudi Arabia','united states','united states','turkey','united states '),
Location=c('America','Africa','Asia','Asia','Asia','America','America','Asia','America','America','Europe','America'),
Design=c('case control','case control','case control','case control','case control','case control','cross sectional','case control','case control','case control','case control','case control'),
year=c(1998,1987,1987,2015,1995,2012,2009,2019,1974,1979,1991,2006),
mean =c(77.8,53.45,113,62.2,85.6,60,81.9,65.5,116,114.9,58,96.1),
sd=c(7.1918,25.19,35.9,12.6,10.3,10,17.6,22.5926,33,22.2,18.6529,2.1575),
n=c(18,40,57,42,15,43,43,33,50,46,20,90)
)}
}
Prop <- {
{
data.frame(
Study=c('Lodigiani 2020','Middledrop 2020','Helms 2020','Bompard 2020','Poyiadi 2020','Grillet 2020','Lorant 2020','Possiy 2020','Klok 2020','Llitjos 2020'),
region=c('Europe','Europe','Europe','Europe','USA','Europe','Europe','Europe','Europe','Europe'),
country=c('italy','netherland','france','france','detroit','france','france','france','netherland','france'),
Design=c('analytic','analytic','analytic','analytic','analytic','descriptive','descriptive','descriptive','descriptive','descriptive'),
design=c('cohort','cohort','cohort','cohort','case control','cross sectional','cross sectional','case series','case series','cross sectional'),
Quality=c('Good','Good','Good','Good','Good','Good','Good','Good','Good','Good'),
n=c(388,198,150,135,328,100,106,107,184,26),
event=c(10,13,25,32,72,23,32,22,65,6)
)
}
}
COR <- {
data.frame(
Study=c('1','2','3','4','5','6','7','8','9'),
cor = c(0.85, 0.7, 0.95,0.85, 0.7, 0.95,0.85, 0.7, 0.95),
n = c(20, 40, 10,20, 40, 10,20, 40, 10)
)
}
if(a == 'SMD'){
.GlobalEnv$SMD = SMD
return(SMD)
} else if(a == 'OR'){
.GlobalEnv$OR = OR
# rm(Olkin95)
# .GlobalEnv$Olkin95 = NULL
return(OR)
} else if(a == 'Mean'){
.GlobalEnv$Mean = Mean
return(Mean)
} else if(a == 'Prop'){
.GlobalEnv$Prop = Prop
return(Prop)
} else if(a == 'Inc1') {
.GlobalEnv$Inc1 = Inc1
return(Inc1)
} else if(a == 'Inc2') {
.GlobalEnv$Inc2 = Inc2
return(Inc2)
} else {
.GlobalEnv$COR = COR
return(COR)
}
}
# created functions ----
source('funcs/pcurve.R', local=T)
source('funcs/find.outliers.R', local=T)
source('funcs/gosh.diagnostics.R', local=T)
source('funcs/InfluenceAnalysis.R', local=T)
delrows <- function(c,df){
k <- as.numeric(length(unlist(as.numeric(unlist(strsplit(as.character(c),','))))))
u <- {
if(k > 1){
c <- as.numeric(unlist(strsplit(as.character(c),',')))
} else {
if(k == 1){if(as.numeric(c) == 0){c <- 0} else {
c <- as.numeric(c)}} else {c <- 0}
}
}
df <- {if(k>1){df[-c(u),]} else if(k == 1 ){df[-c(u),]} else{return(df)}}
}
delcols <- function(c,df){
k <- as.numeric(length(unlist(as.numeric(unlist(strsplit(as.character(c),','))))))
u <- {
if(k > 1){
c <- as.numeric(unlist(strsplit(as.character(c),',')))
} else {
if(k == 1){if(as.numeric(c) == 0){c <- 0} else {
c <- as.numeric(c)}} else {c <- 0}
}
}
df <- {if(k>1){df[,-c(u)]} else if(k == 1 ){df[,-c(u)]} else{return(df)}}
}
# chek: function to check if something is present in larger list
chek <- function(n,h){
b <- 0
for (i in n) {
if(i %in% h){
b = b+1
} else {
b = b
}
}
return(b)
}
getchar <- function(a,sep){
v <- unlist(strsplit(as.character(a),sep))
return(v)
}
dataget <- function(g){
g <- input$file1$datapath
mg <- if(tools::file_ext(g) == 'csv'){
mg <- read.csv(input$file1$datapath, header = input$header,
sep = input$sep, quote = input$quote)}
else{
mg <- readxl::read_excel(input$file1$datapath, sheet = input$sheet,
col_names = input$Colname,
skip = input$Skip)
}
return(mg)
}
dataget2 <- function(g){
if(is.null(input$file1)){
SMD <- metafor::dat.normand1999
colnames(SMD) <- c("Study","source",'n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c');SMD$Study <- as.factor(SMD$Study)
return(SMD)
} else{
g <- input$file1$datapath
SMD <- if(tools::file_ext(g) == 'csv'){
SMD <- read.csv(input$file1$datapath, header = input$header,
sep = input$sep, quote = input$quote)}
else{
SMD <- readxl::read_excel(input$file1$datapath, sheet = input$sheet,
n_max = input$nmax,
col_names = input$Colname,
skip = input$Skip)
}
return(SMD)
}
}
eggers.test = function(x) {
# Validate
x = x
if (x$k < 10) {
warning(paste("Your meta-analysis contains k =",
x$k, "studies. Egger's test may lack the statistical power to detect bias when the number of studies is small (i.e., k<10)."))
}
if (class(x)[1] %in% c("meta", "metabin", "metagen",'metamean' ,"metacont", "metacor", "metainc", "metaprop")) {
# Conduct metabias
eggers = meta::metabias(x, k.min = 3, method = "linreg")
# Get Intercept
intercept = as.numeric(eggers$estimate[1])
# Get SE
se = as.numeric(eggers$estimate[2])
# Calculate 95CI
llci = intercept - qnorm(0.975) * se
ulci = intercept + qnorm(0.975) * se
# Get t
t = as.numeric(eggers$statistic)
# Get df
df = as.numeric(eggers$parameters)
# Get p
p = as.numeric(eggers$p.value)
# Make df
returnlist = list(intercept = intercept,
llci = llci,
ulci = ulci,
t = t,
p = p,
meta.obj = x)
} else {
stop("x must be of type 'metabin', 'metagen', 'metacont', 'metainc' or 'metaprop'")
}
class(returnlist) = "eggers.test"
return(returnlist)
}
# pastreg <- function(a){
# a <- getchar(a,',')
# eq <- c()
# for (i in 1:length(a)) {
# if(i == max(length(a))){
# eq[i] = paste0(a[i])
# } else {
# eq[i] = paste0(a[i],' +')
# }
# }
# paste0(eq,collapse=" ")
# }
pastreg <- function(a,sep){
a <- getchar(a,',')
eq <- c()
for (i in 1:length(a)) {
if(i == max(length(a))){
eq[i] = paste(a[i])
} else {
eq[i] = paste(a[i],sep)
}
}
paste0(eq,collapse=" ")
}
getbias <- function(x){
d <- meta::metabias.meta(x,k.min = 2,method.bias = 'linreg')
if(d$p.value <= 0.05){
c = 'There is funnel plot asymmetry'
} else {
c = 'There is no funnel plot asymmetry'
}
list(model = d,results = c)
}
sdtrimfill <- function(g,trim){
# sqrt(n)*(upper-lower)/3.92
a <- trim$upper
b <- trim$lower
trim$sd <- g$sd
length(trim$sd)=length(trim$TE)
i <- which(is.na(trim$sd))
for (f in i) {
trim$sd[f] = (sqrt(trim$n[f])*(a[f]-b[f]))/3.92
}
return(trim$sd)
}
meantrimfill <- function(g,trim){
trim$mean <- g$mean
length(trim$mean)=length(trim$TE)
i <- which(is.na(trim$mean))
for (f in i) {
trim$mean[f] = trim$TE[f]
}
return(trim$mean)
}
'%!in%' <- function(x,y)!('%in%'(x,y)) # function to negate %in%
getsubgroupvar <- function(data,req) {
x <- colnames(data)
y <- x[which(x %!in% req)]
return(y)
}
# Predefined datasets ----
# SMD data
SMDreqcol <- c('n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c')
# Odd ratio data
ORreqcol <- c('event.e','n.e','event.c','n.c')
# Mean data
Meanreqcol <- c("mean", "sd", "n")
# proportion data:
Propreqcol <- c('event', 'n')
# Correlation
CORreqcol <- c( 'cor','n')
# incidence data:
Increqcol <- c( 'event.e','time.e','event.c','time.c')
# method: A character string indicating which method is to be used for pooling of studies.
# One of "MH", "Inverse", "Cochran", or "GLMM" can be abbreviated.
# sm: A character string indicating which summary measure ("IRR" or "IRD") is to be used for pooling of studies, see Details.
{
# req(input$file1)
# v <- input$file1$datapath
# u <- file_ext(v)
# MyDat <- {
# if(u == 'csv'){
# # csv
# {
# df <- utils::read.csv(v,
# header = input$header,
# sep = input$sep,
# quote = input$quote)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # }
# # else {
# # return(df)
# # }
#
# }
# } else if(u == 'xlsx'){
# # excel
# {
# df <- readxl::read_excel(v,n_max = input$nmax,
# col_names = input$Colname,
# sheet = input$sheet,
# skip = input$Skip)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # }
# # else {
# # return(df)
# # }
#
# }
# } else {
# # excel
# {
# df <- readxl::read_excel(v, sheet = input$sheet, n_max = input$nmax,
# col_names = input$Colname,
# skip = input$Skip)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
#
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # } else {
# # return(df)
# # }
#
# }
# }
# }
} # uncomment if the MyDat reactive doesn't work
{
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# if(input$disp == "head") {
# return(head(df))
# }
# else {
# return(df)
# }
}
# trycatch: ----
# tryCatch({
# v = "F:\\Data science\\Projects\\Research projects\\1- Done\\Published\\1- COVID-19 research\\New folder\\1- Lymphopenia.xlsx"
# df <- switch('csv',
# csv = vroom::vroom(v,n_max = 30, delim = '\t' ,col_names = TRUE, quote = '"')
# # tsv = vroom::vroom(v, delim = "\t"),
# # xlsx = readxl::read_excel(v, n_max = input$nmax, sheet = input$sheet,
# # col_names = input$Colname,skip = input$Skip),
# # validate("Invalid file; Please upload a .csv or .tsv or .xls /.xlsx file")
# )
# df <- delrows('1,2',df)
# df <- delcols('1',df)
# }, error = function(e) {
# # return a safeError if a parsing error occurs
# print('Data is incompatible!')
# stop(safeError(e))
# }
# )
# trim fill practicing ----
# mean ----
# Meanmeta <- meta::metamean(
# mean = mean, sd = sd, n = n,
# studlab = paste(Study),
# data = Mean,
# comb.random = T, comb.fixed = F, prediction = T,hakn = TRUE
# )
# Meanrmeta <- metafor::rma(measure = 'MN', ni= n, mi= mean, sdi = sd, data = Mean,
# #method = Meanmodel()$method.tau,
# test = "knha")
# funnel(Meanmeta$TE,Meanmeta$seTE,
# main = 'Funnel plot',
# refline = Meanmeta$TE.random,
# level=c(90, 95, 99), shade = c("white", "red", "orange"),
# #back = 'grey90', col = 'red', bg = 'blue', cex
# )
# funnel(trimfill(Meanmeta)$TE,trimfill(Meanmeta)$seTE,
# main = 'Funnel plot',
# refline = trimfill(Meanmeta)$TE.random,
# level=c(90, 95, 99), shade = c("white", "red", "orange"),
# pch = ifelse(trimfill(Meanmeta)$trimfill, 1, 16),
# #back = 'grey90', col = 'red', bg = 'blue', cex
# )
# SMD ----
# SMDmeta <- meta::metacont(
# mean.e = mean.e, sd.e = sd.e, n.e= n.e,
# mean.c= mean.c, sd.c = sd.c, n.c = n.c,
# data = gtdata('SMD'), sm = 'SMD'
# )
# SMDmeta1 <- meta::metacont(
# mean.e = mean.e, sd.e = sd.e, n.e= n.e,
# mean.c= mean.c, sd.c = sd.c, n.c = n.c,
# data = rbind(gtdata('SMD'),gtdata('SMD')), sm = 'SMD'
# )
# SMDtrimfill <- trimfill(SMDmeta)
# getWH <- function(model = NULL, data = NULL) {
#
# }
# png('SMD.png')
# forest.meta(SMDmeta)
# # forest.meta(SMDmeta1)
# dev.off()
# drapery(SMDmeta)
# drapery(SMDtrimfill)
# drapery(
# SMDtrimfill, type = "pval", legend = T,
# labels = "studlab", lwd.random = 3,
# xlim = c(input$minSMDxlimd,input$maxSMDxlimd),
# layout = 'linewidth',lwd.max = 2,
# main = input$SMDDraperytitle
# )
# smdlftcl <- getchar("studlab, n.e, mean.e, sd.e, n.c, mean.c, sd.c", ', ')
# forest(
# SMDtrimfill,
# sortvar= unlist(SMDtrimfill['TE']) ,
# # rightcols = c("effect","ci", "w.random"),
# # #rightlabs = c("SMD","95% CI"," Weight"),
# leftcols = smdlftcl,
# # #c("Study", "n.e","mean.e","sd.e","n.c","mean.c","sd.c"),
# # leftlabs = smdlftlb,
# )
# Propmeta <- meta::metaprop(
# event = event, n = n, sm = 'PFT', backtransf = T,
# studlab = paste(Study), comb.fixed = T,
# data = Prop, prediction = T, hakn = TRUE)
# funnel(Propmeta$TE,Propmeta$seTE,
# # main= input$Propfunneltitle,
# xlim = c(Propmeta$TE.random-0.8, Propmeta$TE.random+0.8),
# refline = Propmeta$TE.random,
# level=c(90, 95, 99),
# shade=c("white", "red", "orange")
# )
# par(mar=c(1, 4, 1, 8.1), xpd=TRUE)
# add_legend <- function(...) {
# opar <- par(fig=c(0, 1, 0, 1), oma=c(0, 0, 0, 5),
# mar=c(0, 0, 0, 0), new=TRUE)
# on.exit(par(opar))
# plot(0, 0, type='n', bty='n', xaxt='n', yaxt='n')
# legend(...)
# }
# dev.off()
# par(oma=c(0, 0, 0, 0), mar=c(0, 0, 0, 10))
# par(mar = c(0,0,3,0))
# drapery(Propmeta, type = "pval", legend = F, labels = "studlab", xlim = c(0,1.5), lwd.max = 2)
# legend(
# 'top',
# # x= 1, y = 0.5,
# legend=c("Random effects model","Fixed effects model", "Range of predictions"),
# col=c("red", 'blue', "lightblue"),
# pch=19, lty = 1, lwd = 2,
# # cex = 1.1,
# inset = c(0,-0.1),
# # x.intersp=0.0, xjust=0, yjust=0,
# horiz=T,
# bty='n')
# par(oma=c(0, 0, 0, 10))
# drapery(Propmeta, type = "pval", legend = F, labels = "studlab", xlim = c(0,1), lwd.max = 2)
# legend(par('usr')[2], par('usr')[4], bty='n', xpd=NA,
# c("Random effects model", "Range of predictions"), pch=c(1, 2), lty=c(1,2))
# metaregression practicing ----
# v <- c('year','event.e')
# length(v)
# class(v)
# pastreg('n')
# r <- getsubgroupvar(OR,ORreqcol)
# formula <- parse(text = pastreg('year'))
# f <- metareg(ORmeta, formula = eval(formula))
# class(f)
# f$formula.mods <- ~ paste0(pastreg('year'))
#
# f$b <- unclass(f$b)
# f$b
# f$b <- list(f$b)
# f$b$name <- b
# windows(height = 7, width = 3.5)
# plot(hp ~ mpg, data = mtcars)
# legend(x = c(9.46, 24), y = c(346.32, 298),
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"),
# lty = 1)
#
# plot(hp ~ mpg, data = mtcars)
# leg <- legend("topleft", lty = 1,
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"),
# plot = FALSE)
#
# # adjust as desired
# leftx <- leg$rect$left
# rightx <- (leg$rect$left + leg$rect$w) * 1.2
# topy <- leg$rect$top
# bottomy <- (leg$rect$top - leg$rect$h) * 1
#
# # use the new coordinates to define custom
# legend(x = c(leftx, rightx), y = c(topy, bottomy), lty = 1,
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"))
#
# plot(1)
# text = c("Sub_metering_1","Sub_metering_2","Sub_metering_3")
# legend("topleft"
# ,lty = 1
# ,legend = text
# ,col = c("black","red","blue")
# )
# strwidth(text)
# # [1] 0.1734099 0.1734099 0.1734099
# # half the length
# legend("bottomleft"
# ,lty = 1
# ,legend = text
# ,text.width = strwidth(text)[1]/2
# ,col = c("black","red","blue")
# )
# # double the length
# legend("center"
# ,lty = 1
# ,legend = text
# ,text.width = strwidth(text)[1]*2
# ,col = c("black","red","blue")
# )
Ibrahimhassan94/MAAS documentation built on Feb. 24, 2022, 8:14 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# usethis::edit_r_environ()
# auth0::use_auth0()
options(shiny.port = 8080)
# packages call ----
# library(shiny)
# # library(shinyjs)
# library(colourpicker)
# library(DT)
# library(meta)
# library(metafor)
# library(tools)
# library(readxl)
# library(stringr)
# library(poibin)
# library(gridExtra)
# library(ggplot2)
# library(ggrepel)
# library(fpc)
# library(mclust)
# library(shinyFeedback)
# library(shinymanager)
# library(auth0)
# library(htmlTable)
# library(kableExtra)
# library(knitr)
gtdata <- function(a) {
SMD <- {
SMD <- metafor::dat.normand1999
colnames(SMD) <- c("Study","source",'n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c')
SMD
}
OR <- {
library(meta)
data('Olkin95')
OR <- Olkin95
colnames(OR) <- c('Study','year','event.e','n.e','event.c','n.c')
OR
}
Inc2 <- {
data('smoking')
# data('lungcancer')
Inc2 <- smoking
colnames(Inc2) <- c('studlab','total','event.e', 'time.e', 'event.c', 'time.c')
Inc2
}
Inc1 <- {
Inc1 <- Inc2[,c(1,3,4)]
colnames(Inc2) <- c('studlab','event','time')
Inc1
}
Mean <- {
{data.frame(
Study=c('1','2','3','4','5','6','7','8','9','10','11','12'),
Country=c('US','Nigeria','Saudi Arabia','Iraq','Jordan','brazil','united states','Saudi Arabia','united states','united states','turkey','united states '),
Location=c('America','Africa','Asia','Asia','Asia','America','America','Asia','America','America','Europe','America'),
Design=c('case control','case control','case control','case control','case control','case control','cross sectional','case control','case control','case control','case control','case control'),
year=c(1998,1987,1987,2015,1995,2012,2009,2019,1974,1979,1991,2006),
mean =c(77.8,53.45,113,62.2,85.6,60,81.9,65.5,116,114.9,58,96.1),
sd=c(7.1918,25.19,35.9,12.6,10.3,10,17.6,22.5926,33,22.2,18.6529,2.1575),
n=c(18,40,57,42,15,43,43,33,50,46,20,90)
)}
}
Prop <- {
{
data.frame(
Study=c('Lodigiani 2020','Middledrop 2020','Helms 2020','Bompard 2020','Poyiadi 2020','Grillet 2020','Lorant 2020','Possiy 2020','Klok 2020','Llitjos 2020'),
region=c('Europe','Europe','Europe','Europe','USA','Europe','Europe','Europe','Europe','Europe'),
country=c('italy','netherland','france','france','detroit','france','france','france','netherland','france'),
Design=c('analytic','analytic','analytic','analytic','analytic','descriptive','descriptive','descriptive','descriptive','descriptive'),
design=c('cohort','cohort','cohort','cohort','case control','cross sectional','cross sectional','case series','case series','cross sectional'),
Quality=c('Good','Good','Good','Good','Good','Good','Good','Good','Good','Good'),
n=c(388,198,150,135,328,100,106,107,184,26),
event=c(10,13,25,32,72,23,32,22,65,6)
)
}
}
COR <- {
data.frame(
Study=c('1','2','3','4','5','6','7','8','9'),
cor = c(0.85, 0.7, 0.95,0.85, 0.7, 0.95,0.85, 0.7, 0.95),
n = c(20, 40, 10,20, 40, 10,20, 40, 10)
)
}
if(a == 'SMD'){
.GlobalEnv$SMD = SMD
return(SMD)
} else if(a == 'OR'){
.GlobalEnv$OR = OR
# rm(Olkin95)
# .GlobalEnv$Olkin95 = NULL
return(OR)
} else if(a == 'Mean'){
.GlobalEnv$Mean = Mean
return(Mean)
} else if(a == 'Prop'){
.GlobalEnv$Prop = Prop
return(Prop)
} else if(a == 'Inc1') {
.GlobalEnv$Inc1 = Inc1
return(Inc1)
} else if(a == 'Inc2') {
.GlobalEnv$Inc2 = Inc2
return(Inc2)
} else {
.GlobalEnv$COR = COR
return(COR)
}
}
# created functions ----
source('funcs/pcurve.R', local=T)
source('funcs/find.outliers.R', local=T)
source('funcs/gosh.diagnostics.R', local=T)
source('funcs/InfluenceAnalysis.R', local=T)
delrows <- function(c,df){
k <- as.numeric(length(unlist(as.numeric(unlist(strsplit(as.character(c),','))))))
u <- {
if(k > 1){
c <- as.numeric(unlist(strsplit(as.character(c),',')))
} else {
if(k == 1){if(as.numeric(c) == 0){c <- 0} else {
c <- as.numeric(c)}} else {c <- 0}
}
}
df <- {if(k>1){df[-c(u),]} else if(k == 1 ){df[-c(u),]} else{return(df)}}
}
delcols <- function(c,df){
k <- as.numeric(length(unlist(as.numeric(unlist(strsplit(as.character(c),','))))))
u <- {
if(k > 1){
c <- as.numeric(unlist(strsplit(as.character(c),',')))
} else {
if(k == 1){if(as.numeric(c) == 0){c <- 0} else {
c <- as.numeric(c)}} else {c <- 0}
}
}
df <- {if(k>1){df[,-c(u)]} else if(k == 1 ){df[,-c(u)]} else{return(df)}}
}
# chek: function to check if something is present in larger list
chek <- function(n,h){
b <- 0
for (i in n) {
if(i %in% h){
b = b+1
} else {
b = b
}
}
return(b)
}
getchar <- function(a,sep){
v <- unlist(strsplit(as.character(a),sep))
return(v)
}
dataget <- function(g){
g <- input$file1$datapath
mg <- if(tools::file_ext(g) == 'csv'){
mg <- read.csv(input$file1$datapath, header = input$header,
sep = input$sep, quote = input$quote)}
else{
mg <- readxl::read_excel(input$file1$datapath, sheet = input$sheet,
col_names = input$Colname,
skip = input$Skip)
}
return(mg)
}
dataget2 <- function(g){
if(is.null(input$file1)){
SMD <- metafor::dat.normand1999
colnames(SMD) <- c("Study","source",'n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c');SMD$Study <- as.factor(SMD$Study)
return(SMD)
} else{
g <- input$file1$datapath
SMD <- if(tools::file_ext(g) == 'csv'){
SMD <- read.csv(input$file1$datapath, header = input$header,
sep = input$sep, quote = input$quote)}
else{
SMD <- readxl::read_excel(input$file1$datapath, sheet = input$sheet,
n_max = input$nmax,
col_names = input$Colname,
skip = input$Skip)
}
return(SMD)
}
}
eggers.test = function(x) {
# Validate
x = x
if (x$k < 10) {
warning(paste("Your meta-analysis contains k =",
x$k, "studies. Egger's test may lack the statistical power to detect bias when the number of studies is small (i.e., k<10)."))
}
if (class(x)[1] %in% c("meta", "metabin", "metagen",'metamean' ,"metacont", "metacor", "metainc", "metaprop")) {
# Conduct metabias
eggers = meta::metabias(x, k.min = 3, method = "linreg")
# Get Intercept
intercept = as.numeric(eggers$estimate[1])
# Get SE
se = as.numeric(eggers$estimate[2])
# Calculate 95CI
llci = intercept - qnorm(0.975) * se
ulci = intercept + qnorm(0.975) * se
# Get t
t = as.numeric(eggers$statistic)
# Get df
df = as.numeric(eggers$parameters)
# Get p
p = as.numeric(eggers$p.value)
# Make df
returnlist = list(intercept = intercept,
llci = llci,
ulci = ulci,
t = t,
p = p,
meta.obj = x)
} else {
stop("x must be of type 'metabin', 'metagen', 'metacont', 'metainc' or 'metaprop'")
}
class(returnlist) = "eggers.test"
return(returnlist)
}
# pastreg <- function(a){
# a <- getchar(a,',')
# eq <- c()
# for (i in 1:length(a)) {
# if(i == max(length(a))){
# eq[i] = paste0(a[i])
# } else {
# eq[i] = paste0(a[i],' +')
# }
# }
# paste0(eq,collapse=" ")
# }
pastreg <- function(a,sep){
a <- getchar(a,',')
eq <- c()
for (i in 1:length(a)) {
if(i == max(length(a))){
eq[i] = paste(a[i])
} else {
eq[i] = paste(a[i],sep)
}
}
paste0(eq,collapse=" ")
}
getbias <- function(x){
d <- meta::metabias.meta(x,k.min = 2,method.bias = 'linreg')
if(d$p.value <= 0.05){
c = 'There is funnel plot asymmetry'
} else {
c = 'There is no funnel plot asymmetry'
}
list(model = d,results = c)
}
sdtrimfill <- function(g,trim){
# sqrt(n)*(upper-lower)/3.92
a <- trim$upper
b <- trim$lower
trim$sd <- g$sd
length(trim$sd)=length(trim$TE)
i <- which(is.na(trim$sd))
for (f in i) {
trim$sd[f] = (sqrt(trim$n[f])*(a[f]-b[f]))/3.92
}
return(trim$sd)
}
meantrimfill <- function(g,trim){
trim$mean <- g$mean
length(trim$mean)=length(trim$TE)
i <- which(is.na(trim$mean))
for (f in i) {
trim$mean[f] = trim$TE[f]
}
return(trim$mean)
}
'%!in%' <- function(x,y)!('%in%'(x,y)) # function to negate %in%
getsubgroupvar <- function(data,req) {
x <- colnames(data)
y <- x[which(x %!in% req)]
return(y)
}
# Predefined datasets ----
# SMD data
SMDreqcol <- c('n.e' ,'mean.e', 'sd.e', 'n.c' ,'mean.c', 'sd.c')
# Odd ratio data
ORreqcol <- c('event.e','n.e','event.c','n.c')
# Mean data
Meanreqcol <- c("mean", "sd", "n")
# proportion data:
Propreqcol <- c('event', 'n')
# Correlation
CORreqcol <- c( 'cor','n')
# incidence data:
Increqcol <- c( 'event.e','time.e','event.c','time.c')
# method: A character string indicating which method is to be used for pooling of studies.
# One of "MH", "Inverse", "Cochran", or "GLMM" can be abbreviated.
# sm: A character string indicating which summary measure ("IRR" or "IRD") is to be used for pooling of studies, see Details.
{
# req(input$file1)
# v <- input$file1$datapath
# u <- file_ext(v)
# MyDat <- {
# if(u == 'csv'){
# # csv
# {
# df <- utils::read.csv(v,
# header = input$header,
# sep = input$sep,
# quote = input$quote)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # }
# # else {
# # return(df)
# # }
#
# }
# } else if(u == 'xlsx'){
# # excel
# {
# df <- readxl::read_excel(v,n_max = input$nmax,
# col_names = input$Colname,
# sheet = input$sheet,
# skip = input$Skip)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # }
# # else {
# # return(df)
# # }
#
# }
# } else {
# # excel
# {
# df <- readxl::read_excel(v, sheet = input$sheet, n_max = input$nmax,
# col_names = input$Colname,
# skip = input$Skip)
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
#
# return(df)
# # if(input$disp == "head") {
# # return(head(df))
# # } else {
# # return(df)
# # }
#
# }
# }
# }
} # uncomment if the MyDat reactive doesn't work
{
# df <- delrows(input$delr,df)
# df <- delcols(input$delc,df)
# return(df)
# if(input$disp == "head") {
# return(head(df))
# }
# else {
# return(df)
# }
}
# trycatch: ----
# tryCatch({
# v = "F:\\Data science\\Projects\\Research projects\\1- Done\\Published\\1- COVID-19 research\\New folder\\1- Lymphopenia.xlsx"
# df <- switch('csv',
# csv = vroom::vroom(v,n_max = 30, delim = '\t' ,col_names = TRUE, quote = '"')
# # tsv = vroom::vroom(v, delim = "\t"),
# # xlsx = readxl::read_excel(v, n_max = input$nmax, sheet = input$sheet,
# # col_names = input$Colname,skip = input$Skip),
# # validate("Invalid file; Please upload a .csv or .tsv or .xls /.xlsx file")
# )
# df <- delrows('1,2',df)
# df <- delcols('1',df)
# }, error = function(e) {
# # return a safeError if a parsing error occurs
# print('Data is incompatible!')
# stop(safeError(e))
# }
# )
# trim fill practicing ----
# mean ----
# Meanmeta <- meta::metamean(
# mean = mean, sd = sd, n = n,
# studlab = paste(Study),
# data = Mean,
# comb.random = T, comb.fixed = F, prediction = T,hakn = TRUE
# )
# Meanrmeta <- metafor::rma(measure = 'MN', ni= n, mi= mean, sdi = sd, data = Mean,
# #method = Meanmodel()$method.tau,
# test = "knha")
# funnel(Meanmeta$TE,Meanmeta$seTE,
# main = 'Funnel plot',
# refline = Meanmeta$TE.random,
# level=c(90, 95, 99), shade = c("white", "red", "orange"),
# #back = 'grey90', col = 'red', bg = 'blue', cex
# )
# funnel(trimfill(Meanmeta)$TE,trimfill(Meanmeta)$seTE,
# main = 'Funnel plot',
# refline = trimfill(Meanmeta)$TE.random,
# level=c(90, 95, 99), shade = c("white", "red", "orange"),
# pch = ifelse(trimfill(Meanmeta)$trimfill, 1, 16),
# #back = 'grey90', col = 'red', bg = 'blue', cex
# )
# SMD ----
# SMDmeta <- meta::metacont(
# mean.e = mean.e, sd.e = sd.e, n.e= n.e,
# mean.c= mean.c, sd.c = sd.c, n.c = n.c,
# data = gtdata('SMD'), sm = 'SMD'
# )
# SMDmeta1 <- meta::metacont(
# mean.e = mean.e, sd.e = sd.e, n.e= n.e,
# mean.c= mean.c, sd.c = sd.c, n.c = n.c,
# data = rbind(gtdata('SMD'),gtdata('SMD')), sm = 'SMD'
# )
# SMDtrimfill <- trimfill(SMDmeta)
# getWH <- function(model = NULL, data = NULL) {
#
# }
# png('SMD.png')
# forest.meta(SMDmeta)
# # forest.meta(SMDmeta1)
# dev.off()
# drapery(SMDmeta)
# drapery(SMDtrimfill)
# drapery(
# SMDtrimfill, type = "pval", legend = T,
# labels = "studlab", lwd.random = 3,
# xlim = c(input$minSMDxlimd,input$maxSMDxlimd),
# layout = 'linewidth',lwd.max = 2,
# main = input$SMDDraperytitle
# )
# smdlftcl <- getchar("studlab, n.e, mean.e, sd.e, n.c, mean.c, sd.c", ', ')
# forest(
# SMDtrimfill,
# sortvar= unlist(SMDtrimfill['TE']) ,
# # rightcols = c("effect","ci", "w.random"),
# # #rightlabs = c("SMD","95% CI"," Weight"),
# leftcols = smdlftcl,
# # #c("Study", "n.e","mean.e","sd.e","n.c","mean.c","sd.c"),
# # leftlabs = smdlftlb,
# )
# Propmeta <- meta::metaprop(
# event = event, n = n, sm = 'PFT', backtransf = T,
# studlab = paste(Study), comb.fixed = T,
# data = Prop, prediction = T, hakn = TRUE)
# funnel(Propmeta$TE,Propmeta$seTE,
# # main= input$Propfunneltitle,
# xlim = c(Propmeta$TE.random-0.8, Propmeta$TE.random+0.8),
# refline = Propmeta$TE.random,
# level=c(90, 95, 99),
# shade=c("white", "red", "orange")
# )
# par(mar=c(1, 4, 1, 8.1), xpd=TRUE)
# add_legend <- function(...) {
# opar <- par(fig=c(0, 1, 0, 1), oma=c(0, 0, 0, 5),
# mar=c(0, 0, 0, 0), new=TRUE)
# on.exit(par(opar))
# plot(0, 0, type='n', bty='n', xaxt='n', yaxt='n')
# legend(...)
# }
# dev.off()
# par(oma=c(0, 0, 0, 0), mar=c(0, 0, 0, 10))
# par(mar = c(0,0,3,0))
# drapery(Propmeta, type = "pval", legend = F, labels = "studlab", xlim = c(0,1.5), lwd.max = 2)
# legend(
# 'top',
# # x= 1, y = 0.5,
# legend=c("Random effects model","Fixed effects model", "Range of predictions"),
# col=c("red", 'blue', "lightblue"),
# pch=19, lty = 1, lwd = 2,
# # cex = 1.1,
# inset = c(0,-0.1),
# # x.intersp=0.0, xjust=0, yjust=0,
# horiz=T,
# bty='n')
# par(oma=c(0, 0, 0, 10))
# drapery(Propmeta, type = "pval", legend = F, labels = "studlab", xlim = c(0,1), lwd.max = 2)
# legend(par('usr')[2], par('usr')[4], bty='n', xpd=NA,
# c("Random effects model", "Range of predictions"), pch=c(1, 2), lty=c(1,2))
# metaregression practicing ----
# v <- c('year','event.e')
# length(v)
# class(v)
# pastreg('n')
# r <- getsubgroupvar(OR,ORreqcol)
# formula <- parse(text = pastreg('year'))
# f <- metareg(ORmeta, formula = eval(formula))
# class(f)
# f$formula.mods <- ~ paste0(pastreg('year'))
#
# f$b <- unclass(f$b)
# f$b
# f$b <- list(f$b)
# f$b$name <- b
# windows(height = 7, width = 3.5)
# plot(hp ~ mpg, data = mtcars)
# legend(x = c(9.46, 24), y = c(346.32, 298),
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"),
# lty = 1)
#
# plot(hp ~ mpg, data = mtcars)
# leg <- legend("topleft", lty = 1,
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"),
# plot = FALSE)
#
# # adjust as desired
# leftx <- leg$rect$left
# rightx <- (leg$rect$left + leg$rect$w) * 1.2
# topy <- leg$rect$top
# bottomy <- (leg$rect$top - leg$rect$h) * 1
#
# # use the new coordinates to define custom
# legend(x = c(leftx, rightx), y = c(topy, bottomy), lty = 1,
# legend = c("Sub_metering_1","Sub_metering_2","Sub_metering_3"),
# col = c("black","red","blue"))
#
# plot(1)
# text = c("Sub_metering_1","Sub_metering_2","Sub_metering_3")
# legend("topleft"
# ,lty = 1
# ,legend = text
# ,col = c("black","red","blue")
# )
# strwidth(text)
# # [1] 0.1734099 0.1734099 0.1734099
# # half the length
# legend("bottomleft"
# ,lty = 1
# ,legend = text
# ,text.width = strwidth(text)[1]/2
# ,col = c("black","red","blue")
# )
# # double the length
# legend("center"
# ,lty = 1
# ,legend = text
# ,text.width = strwidth(text)[1]*2
# ,col = c("black","red","blue")
# )
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.