R/read.rm5-internal.R
In guido-s/meta: General Package for Meta-Analysis
Defines functions
read.rm5.rm5
read.rm5.csv
oct2txt
extract_outcomes
##
##
## Definition of auxiliary functions to import RevMan 5 analysis datasets
##
##
extract_outcomes <- function(txt, outcome.type, res,
comp.no, complab,
debug = 0) {
##
pattern1 <- paste0("<", outcome.type, "_OUTCOME")
pattern2 <- paste0("</", outcome.type, "_OUTCOME")
sel1 <- grep(pattern1, txt)
sel2 <- grep(pattern2, txt)
##
if (length(sel1) > 0 | length(sel2) > 0) {
##
if (debug)
cat(paste0("\n*** ", outcome.type, "_OUTCOME ***\n"))
##
if (length(sel1) != length(sel2))
stop("Malformed XML file (tag: ", outcome.type, "_OUTCOME)")
##
for (j in seq(along = sel1)) {
txt.j <- txt[sel1[j]:sel2[j]]
sel.data.j <- c(grep(paste0("<", outcome.type, "_DATA"), txt.j) - 1,
grep(paste0("<", outcome.type, "_SUBGROUP"), txt.j) - 1)
if (outcome.type %in% c("IV", "IPD"))
sel.data.j <- c(sel.data.j, grep("</EFFECT_MEASURE>", txt.j))
else
sel.data.j <- c(sel.data.j, grep("</GRAPH_LABEL_2>", txt.j))
if (length(sel.data.j) > 0)
sel.j <- c(1:(max(c(6, min(sel.data.j)))), length(txt.j))
else
sel.j <- c(1:6, length(txt.j))
##
xml.j <- as_xml_document(paste(txt.j[sel.j], collapse = " "))
##
outcome.no <- as.numeric(xml_attr(xml.j, "NO"))
outclab <- xml_text(xml_find_all(xml.j, "//NAME"))
##
if (debug) {
cat(paste0("Outcome.no: ", outcome.no, "\n"))
cat(paste0("outclab: ", outclab, "\n"))
##
if (debug == 3)
print(txt.j[sel.j])
}
##
overall <- xml_attr(xml.j, "TOTALS") == "YES"
test.subgroup <- xml_attr(xml.j, "SUBGROUP_TEST") == "YES"
##
n.studies <- as.numeric(xml_attr(xml.j, "DF")) + 1
##
type <- switch(outcome.type,
DICH = "D",
CONT = "C",
IV = "I",
IPD = "I")
##
method <- xml_attr(xml.j, "METHOD")
if (is.na(method) & outcome.type == "IPD")
method <- "Peto"
else if (is.na(method))
method <- "Inverse"
else if (method == "IV")
method <- "Inverse"
##
sm <- xml_attr(xml.j, "EFFECT_MEASURE")
if (is.na(sm)) {
sm <- xml_text(xml_find_all(xml.j, "//EFFECT_MEASURE"))
sm[tolower(sm) == "odds ratio"] <- "OR"
sm[tolower(sm) == "peto odds ratio"] <- "OR"
sm[tolower(sm) == "peto_or"] <- "OR"
sm[tolower(sm) == "odds ratio (non-event)"] <- "OR"
sm[tolower(sm) == "risk ratio"] <- "RR"
sm[tolower(sm) == "risk difference"] <- "RD"
sm[tolower(sm) == "mean difference"] <- "MD"
sm[tolower(sm) == "standardized mean difference"] <- "SMD"
sm[tolower(sm) == "std. mean difference"] <- "SMD"
sm[tolower(sm) == "hazard ratio"] <- "HR"
}
##
logscale <- xml_attr(xml.j, "LOG_DATA") == "NO"
##
random <- xml_attr(xml.j, "RANDOM")
if (is.na(random) & outcome.type == "IPD")
random <- "NO"
model <- ifelse(random == "NO", "Fixed", "Random")
common <- model == "Fixed"
random <- model == "Random"
##
TE.pooled <- as.numeric(xml_attr(xml.j, "EFFECT_SIZE"))
lower.pooled <- as.numeric(xml_attr(xml.j, "CI_START"))
upper.pooled <- as.numeric(xml_attr(xml.j, "CI_END"))
weight.pooled <- as.numeric(xml_attr(xml.j, "WEIGHT"))
level <- as.numeric(xml_attr(xml.j, "CI_STUDY")) / 100
level.ma <- as.numeric(xml_attr(xml.j, "CI_TOTAL")) / 100
##
Z.pooled <- as.numeric(xml_attr(xml.j, "Z"))
pval.TE.pooled <- as.numeric(xml_attr(xml.j, "P_Z"))
Q <- as.numeric(xml_attr(xml.j, "Q"))
pval.Q <- as.numeric(xml_attr(xml.j, "P_Q"))
I2 <- as.numeric(xml_attr(xml.j, "I2"))
tau2 <- as.numeric(xml_attr(xml.j, "TAU2"))
##
event.e.pooled <- as.numeric(xml_attr(xml.j, "EVENTS_1"))
n.e.pooled <- as.numeric(xml_attr(xml.j, "TOTAL_1"))
event.c.pooled <- as.numeric(xml_attr(xml.j, "EVENTS_2"))
n.c.pooled <- as.numeric(xml_attr(xml.j, "TOTAL_2"))
##
swap.events <- xml_attr(xml.j, "SWAP_EVENTS") != "NO"
##
label.e <- xml_text(xml_find_all(xml.j, "//GROUP_LABEL_1"))
label.c <- xml_text(xml_find_all(xml.j, "//GROUP_LABEL_2"))
label.left <- xml_text(xml_find_all(xml.j, "//GRAPH_LABEL_1"))
label.right <- xml_text(xml_find_all(xml.j, "//GRAPH_LABEL_2"))
##
## Subgroups
##
sel.subgroup1 <- grep(paste0("<", outcome.type, "_SUBGROUP"), txt.j)
sel.subgroup2 <- grep(paste0("</", outcome.type, "_SUBGROUP"), txt.j)
##
if (length(sel.subgroup1 > 0) | length(sel.subgroup2) > 0) {
if (debug)
cat(paste0("\n** ", outcome.type, "_SUBGROUP **\n"))
##
if (length(sel.subgroup1) != length(sel.subgroup2))
stop("Malformed XML file (tag: ", outcome.type, "_SUBGROUP)")
##
for (k in seq(along = sel.subgroup1)) {
txt.jk <- txt.j[sel.subgroup1[k]:sel.subgroup2[k]]
sel.data.jk <- c(grep(paste0("<", outcome.type, "_DATA"), txt.jk) - 1,
grep("</NAME>", txt.jk))
if (length(sel.data.jk) > 0)
sel.jk <- unique(c(1:(max(c(2, min(sel.data.jk)))), length(txt.jk)))
else
sel.jk <- unique(c(1:2, length(txt.jk)))
##
xml.jk <- as_xml_document(paste(txt.jk[sel.jk], collapse = " "))
##
group.no <- as.numeric(xml_attr(xml.jk, "NO"))
grplab <- xml_text(xml_find_all(xml.jk, "//NAME"))
##
if (debug) {
cat(paste0("Group.no: ", group.no, "\n"))
cat(paste0("grplab: ", grplab, "\n"))
##
if (debug == 3)
print(txt.jk[sel.jk])
}
##
Q.w <- as.numeric(xml_attr(xml.jk, "NO"))
pval.Q.w <- as.numeric(xml_attr(xml.jk, "P_CHI2"))
I2.w <- as.numeric(xml_attr(xml.jk, "I2"))
##
## Data
##
sel.data1 <- grep(paste0("<", outcome.type, "_DATA"), txt.jk)
##
sel1.data2 <- grepl("/>", txt.jk)
sel2.data2 <- grepl(paste0("</", outcome.type, "_DATA"), txt.jk)
sel3.data2 <-
!(grepl("<GROUP_LABEL", txt.jk) |
grepl("<GRAPH_LABEL", txt.jk) |
grepl("<EFFECT_MEASURE", txt.jk))
sel.data2 <-
seq_along(txt.jk)[(sel1.data2 | sel2.data2) & sel3.data2]
##
if (length(sel.data1) != length(sel.data2)) {
if (debug == 3) {
print(txt.jk)
cat(paste0("sel.data1: ", sel.data1, "\n"))
cat(paste0("sel.data2: ", sel.data2, "\n"))
##
print(data.frame(sel1.data2, sel2.data2, sel3.data2))
}
stop("Malformed XML file (tag: ", outcome.type, "_DATA)")
}
##
event.e <- n.e <- event.c <- n.c <-
mean.e <- sd.e <- mean.c <- sd.c <-
O.E <- V <-
TE <- seTE <- lower.TE <- upper.TE <-
weight <- order <-
rep(NA, length(sel.data1))
##
id <- rep("", length(sel.data1))
##
if (length(sel.data1) > 0) {
if (debug)
cat(paste0("\n* ", outcome.type, "_DATA *\n"))
for (l in seq(along = sel.data1)) {
txt.jkl <- paste(txt.jk[sel.data1[l]:sel.data2[l]],
collapse = "")
##
if (debug == 3)
print(txt.jk[sel.data1[l]:sel.data2[l]])
##
xml.jkl <- as_xml_document(txt.jkl)
##
id[l] <- xml_attr(xml.jkl, "STUDY_ID")
##
event.e[l] <- as.numeric(xml_attr(xml.jkl, "EVENTS_1"))
n.e[l] <- as.numeric(xml_attr(xml.jkl, "TOTAL_1"))
mean.e[l] <- as.numeric(xml_attr(xml.jkl, "MEAN_1"))
sd.e[l] <- as.numeric(xml_attr(xml.jkl, "SD_1"))
##
event.c[l] <- as.numeric(xml_attr(xml.jkl, "EVENTS_2"))
n.c[l] <- as.numeric(xml_attr(xml.jkl, "TOTAL_2"))
mean.c[l] <- as.numeric(xml_attr(xml.jkl, "MEAN_2"))
sd.c[l] <- as.numeric(xml_attr(xml.jkl, "SD_2"))
##
O.E[l] <- as.numeric(xml_attr(xml.jkl, "O_E"))
V[l] <- as.numeric(xml_attr(xml.jkl, "VAR"))
##
TE[l] <- as.numeric(xml_attr(xml.jkl, "EFFECT_SIZE"))
seTE[l] <- as.numeric(xml_attr(xml.jkl, "SE"))
lower.TE[l] <- as.numeric(xml_attr(xml.jkl, "CI_START"))
upper.TE[l] <- as.numeric(xml_attr(xml.jkl, "CI_END"))
##
weight[l] <- as.numeric(xml_attr(xml.jkl, "WEIGHT"))
order[l] <- as.numeric(xml_attr(xml.jkl, "ORDER"))
}
##
res.new <-
data.frame(comp.no, outcome.no, group.no,
id = id,
event.e = event.e, n.e = n.e,
event.c = event.c, n.c = n.c,
mean.e = mean.e, sd.e = sd.e,
mean.c = mean.c, sd.c = sd.c,
O.E = O.E, V = V,
TE = TE, seTE = seTE,
lower.TE = lower.TE, upper.TE = upper.TE,
weight = weight, order = order,
level = level,
grplab = grplab,
overall = overall,
test.subgroup = test.subgroup,
type = type, method = method, sm = sm, model = model,
common = common, random = random,
outclab = outclab,
k = n.studies,
event.e.pooled = event.e.pooled,
n.e.pooled = n.e.pooled,
event.c.pooled = event.c.pooled,
n.c.pooled = n.c.pooled,
TE.pooled = TE.pooled,
lower.pooled = lower.pooled,
upper.pooled = upper.pooled,
weight.pooled = weight.pooled,
level.ma = level.ma,
Z.pooled = Z.pooled, pval.TE.pooled = pval.TE.pooled,
Q = Q, pval.Q = pval.Q,
I2 = I2, tau2 = tau2,
Q.w = Q.w, pval.Q.w = pval.Q.w, I2.w = I2.w,
swap.events = swap.events, logscale = logscale,
label.e = label.e, label.c = label.c,
label.left = label.left,
label.right = label.right,
complab = complab)
##
if (debug >= 2) {
cat("\n* New data: *\n")
print(res.new)
}
res <- rbind(res, res.new)
}
}
}
else {
group.no <- NA
grplab <- ""
Q.w <- NA
pval.Q.w <- NA
I2.w <- NA
##
## Data
##
sel.data1 <- grep(paste0("<", outcome.type, "_DATA"), txt.j)
##
sel1.data2 <- grepl("/>", txt.j)
sel2.data2 <- grepl(paste0("</", outcome.type, "_DATA"), txt.j)
sel3.data2 <-
!(grepl("<GROUP_LABEL", txt.j) |
grepl("<GRAPH_LABEL", txt.j) |
grepl("<EFFECT_MEASURE", txt.j))
sel.data2 <-
seq_along(txt.j)[(sel1.data2 | sel2.data2) & sel3.data2]
##
if (length(sel.data1) != length(sel.data2)) {
if (debug == 3) {
print(txt.j)
cat(paste0("sel.data1: ", sel.data1, "\n"))
cat(paste0("sel.data2: ", sel.data2, "\n"))
##
print(data.frame(sel1.data2, sel2.data2, sel3.data2))
}
stop("Malformed XML file (tag: ", outcome.type, "_DATA)")
}
##
event.e <- n.e <- event.c <- n.c <-
mean.e <- sd.e <- mean.c <- sd.c <-
O.E <- V <-
TE <- seTE <- lower.TE <- upper.TE <-
weight <- order <-
rep(NA, length(sel.data1))
##
id <- rep("", length(sel.data1))
##
if (length(sel.data1) > 0) {
if (debug) {
cat(paste0("\n* ", outcome.type, "_DATA *\n"))
print(sel.data1)
}
##
for (k in seq(along = sel.data1)) {
txt.jk <- paste(txt.j[sel.data1[k]:sel.data2[k]], collapse = "")
##
if (debug == 3)
print(txt.j[sel.data1[k]:sel.data2[k]])
##
xml.jk <- as_xml_document(txt.jk)
##
id[k] <- xml_attr(xml.jk, "STUDY_ID")
##
event.e[k] <- as.numeric(xml_attr(xml.jk, "EVENTS_1"))
n.e[k] <- as.numeric(xml_attr(xml.jk, "TOTAL_1"))
mean.e[k] <- as.numeric(xml_attr(xml.jk, "MEAN_1"))
sd.e[k] <- as.numeric(xml_attr(xml.jk, "SD_1"))
##
event.c[k] <- as.numeric(xml_attr(xml.jk, "EVENTS_2"))
n.c[k] <- as.numeric(xml_attr(xml.jk, "TOTAL_2"))
mean.c[k] <- as.numeric(xml_attr(xml.jk, "MEAN_2"))
sd.c[k] <- as.numeric(xml_attr(xml.jk, "SD_2"))
##
O.E[k] <- as.numeric(xml_attr(xml.jk, "O_E"))
V[k] <- as.numeric(xml_attr(xml.jk, "VAR"))
##
TE[k] <- as.numeric(xml_attr(xml.jk, "EFFECT_SIZE"))
seTE[k] <- as.numeric(xml_attr(xml.jk, "SE"))
lower.TE[k] <- as.numeric(xml_attr(xml.jk, "CI_START"))
upper.TE[k] <- as.numeric(xml_attr(xml.jk, "CI_END"))
##
weight[k] <- as.numeric(xml_attr(xml.jk, "WEIGHT"))
order[k] <- as.numeric(xml_attr(xml.jk, "ORDER"))
}
##
res.new <-
data.frame(comp.no, outcome.no, group.no,
id = id,
event.e = event.e, n.e = n.e,
event.c = event.c, n.c = n.c,
mean.e = mean.e, sd.e = sd.e,
mean.c = mean.c, sd.c = sd.c,
O.E = O.E, V = V,
TE = TE, seTE = seTE,
lower.TE = lower.TE, upper.TE = upper.TE,
weight = weight, order = order,
level = level,
grplab = grplab,
overall = overall,
test.subgroup = test.subgroup,
type = type, method = method, sm = sm, model = model,
common = common, random = random,
outclab = outclab,
k = n.studies,
event.e.pooled = event.e.pooled,
n.e.pooled = n.e.pooled,
event.c.pooled = event.c.pooled,
n.c.pooled = n.c.pooled,
TE.pooled = TE.pooled,
lower.pooled = lower.pooled,
upper.pooled = upper.pooled,
weight.pooled = weight.pooled,
level.ma = level.ma,
Z.pooled = Z.pooled, pval.TE.pooled = pval.TE.pooled,
Q = Q, pval.Q = pval.Q,
I2 = I2, tau2 = tau2,
Q.w = Q.w, pval.Q.w = pval.Q.w, I2.w = I2.w,
swap.events = swap.events, logscale = logscale,
label.e = label.e, label.c = label.c,
label.left = label.left,
label.right = label.right,
complab = complab)
##
if (debug >= 2) {
cat("\n* New data: *\n")
print(res.new)
}
##
res <- rbind(res, res.new)
}
}
}
}
##
res
}
oct2txt <- function(txt) {
txt <- gsub("\200", "EUR", txt, useBytes = TRUE)
txt <- gsub("\202", "'", txt, useBytes = TRUE)
txt <- gsub("\203", "f", txt, useBytes = TRUE)
txt <- gsub("\204", '"', txt, useBytes = TRUE)
txt <- gsub("\205", "...", txt, useBytes = TRUE)
txt <- gsub("\206", "+", txt, useBytes = TRUE)
txt <- gsub("\207", "+", txt, useBytes = TRUE)
txt <- gsub("\210", "^", txt, useBytes = TRUE)
txt <- gsub("\211", "%%", txt, useBytes = TRUE)
txt <- gsub("\212", "S", txt, useBytes = TRUE)
txt <- gsub("\213", "'", txt, useBytes = TRUE)
txt <- gsub("\214", "OE", txt, useBytes = TRUE)
txt <- gsub("\216", "Z", txt, useBytes = TRUE)
txt <- gsub("\221", "'", txt, useBytes = TRUE)
txt <- gsub("\222", "'", txt, useBytes = TRUE)
txt <- gsub("\223", '"', txt, useBytes = TRUE)
txt <- gsub("\224", '"', txt, useBytes = TRUE)
txt <- gsub("\225", "-", txt, useBytes = TRUE)
txt <- gsub("\226", "-", txt, useBytes = TRUE)
txt <- gsub("\227", "-", txt, useBytes = TRUE)
txt <- gsub("\230", "~", txt, useBytes = TRUE)
txt <- gsub("\231", "TM", txt, useBytes = TRUE)
txt <- gsub("\232", "S", txt, useBytes = TRUE)
txt <- gsub("\233", "'", txt, useBytes = TRUE)
txt <- gsub("\234", "oe", txt, useBytes = TRUE)
txt <- gsub("\237", "Y", txt, useBytes = TRUE)
txt <- gsub("\240", " ", txt, useBytes = TRUE)
txt <- gsub("\241", "!", txt, useBytes = TRUE)
txt <- gsub("\242", "cent", txt, useBytes = TRUE)
txt <- gsub("\243", "Pound", txt, useBytes = TRUE)
txt <- gsub("\244", "C", txt, useBytes = TRUE)
txt <- gsub("\245", "Yen", txt, useBytes = TRUE)
txt <- gsub("\246", "|", txt, useBytes = TRUE)
txt <- gsub("\247", "S", txt, useBytes = TRUE)
txt <- gsub("\250", "", txt, useBytes = TRUE)
txt <- gsub("\251", "(C)", txt, useBytes = TRUE)
txt <- gsub("\252", "", txt, useBytes = TRUE)
txt <- gsub("\253", "'", txt, useBytes = TRUE)
txt <- gsub("\254", "-", txt, useBytes = TRUE)
txt <- gsub("\255", "-", txt, useBytes = TRUE)
txt <- gsub("\256", "(R)", txt, useBytes = TRUE)
txt <- gsub("\257", "-", txt, useBytes = TRUE)
txt <- gsub("\260", "o", txt, useBytes = TRUE)
txt <- gsub("\261", "+/-", txt, useBytes = TRUE)
txt <- gsub("\262", "2", txt, useBytes = TRUE)
txt <- gsub("\263", "3", txt, useBytes = TRUE)
txt <- gsub("\264", "", txt, useBytes = TRUE)
txt <- gsub("\265", "mu", txt, useBytes = TRUE)
txt <- gsub("\266", "", txt, useBytes = TRUE)
txt <- gsub("\267", ".", txt, useBytes = TRUE)
txt <- gsub("\270", " ", txt, useBytes = TRUE)
txt <- gsub("\271", "1", txt, useBytes = TRUE)
txt <- gsub("\272", "o", txt, useBytes = TRUE)
txt <- gsub("\273", '"', txt, useBytes = TRUE)
txt <- gsub("\274", "1/4", txt, useBytes = TRUE)
txt <- gsub("\275", "1/2", txt, useBytes = TRUE)
txt <- gsub("\276", "3/4", txt, useBytes = TRUE)
txt <- gsub("\277", "?", txt, useBytes = TRUE)
txt <- gsub("\300", "A", txt, useBytes = TRUE)
txt <- gsub("\301", "A", txt, useBytes = TRUE)
txt <- gsub("\302", "A", txt, useBytes = TRUE)
txt <- gsub("\303", "A", txt, useBytes = TRUE)
txt <- gsub("\304", "A", txt, useBytes = TRUE)
txt <- gsub("\305", "A", txt, useBytes = TRUE)
txt <- gsub("\306", "AE", txt, useBytes = TRUE)
txt <- gsub("\307", "C", txt, useBytes = TRUE)
txt <- gsub("\310", "E", txt, useBytes = TRUE)
txt <- gsub("\311", "E", txt, useBytes = TRUE)
txt <- gsub("\312", "E", txt, useBytes = TRUE)
txt <- gsub("\313", "E", txt, useBytes = TRUE)
txt <- gsub("\314", "I", txt, useBytes = TRUE)
txt <- gsub("\315", "I", txt, useBytes = TRUE)
txt <- gsub("\316", "I", txt, useBytes = TRUE)
txt <- gsub("\317", "I", txt, useBytes = TRUE)
txt <- gsub("\320", "E", txt, useBytes = TRUE)
txt <- gsub("\321", "N", txt, useBytes = TRUE)
txt <- gsub("\322", "O", txt, useBytes = TRUE)
txt <- gsub("\323", "O", txt, useBytes = TRUE)
txt <- gsub("\324", "O", txt, useBytes = TRUE)
txt <- gsub("\325", "O", txt, useBytes = TRUE)
txt <- gsub("\326", "O", txt, useBytes = TRUE)
txt <- gsub("\327", "x", txt, useBytes = TRUE)
txt <- gsub("\330", "O", txt, useBytes = TRUE)
txt <- gsub("\331", "U", txt, useBytes = TRUE)
txt <- gsub("\332", "U", txt, useBytes = TRUE)
txt <- gsub("\333", "U", txt, useBytes = TRUE)
txt <- gsub("\334", "U", txt, useBytes = TRUE)
txt <- gsub("\335", "Y", txt, useBytes = TRUE)
txt <- gsub("\336", "T", txt, useBytes = TRUE)
txt <- gsub("\337", "ss", txt, useBytes = TRUE)
txt <- gsub("\340", "a", txt, useBytes = TRUE)
txt <- gsub("\341", "a", txt, useBytes = TRUE)
txt <- gsub("\342", "a", txt, useBytes = TRUE)
txt <- gsub("\343", "a", txt, useBytes = TRUE)
txt <- gsub("\344", "a", txt, useBytes = TRUE)
txt <- gsub("\345", "a", txt, useBytes = TRUE)
txt <- gsub("\346", "a", txt, useBytes = TRUE)
txt <- gsub("\347", "c", txt, useBytes = TRUE)
txt <- gsub("\350", "e", txt, useBytes = TRUE)
txt <- gsub("\351", "e", txt, useBytes = TRUE)
txt <- gsub("\352", "e", txt, useBytes = TRUE)
txt <- gsub("\353", "e", txt, useBytes = TRUE)
txt <- gsub("\354", "i", txt, useBytes = TRUE)
txt <- gsub("\355", "i", txt, useBytes = TRUE)
txt <- gsub("\356", "i", txt, useBytes = TRUE)
txt <- gsub("\357", "i", txt, useBytes = TRUE)
txt <- gsub("\360", "e", txt, useBytes = TRUE)
txt <- gsub("\361", "n", txt, useBytes = TRUE)
txt <- gsub("\362", "o", txt, useBytes = TRUE)
txt <- gsub("\363", "o", txt, useBytes = TRUE)
txt <- gsub("\364", "o", txt, useBytes = TRUE)
txt <- gsub("\365", "o", txt, useBytes = TRUE)
txt <- gsub("\366", "o", txt, useBytes = TRUE)
txt <- gsub("\367", "/", txt, useBytes = TRUE)
txt <- gsub("\370", "o", txt, useBytes = TRUE)
txt <- gsub("\371", "u", txt, useBytes = TRUE)
txt <- gsub("\372", "u", txt, useBytes = TRUE)
txt <- gsub("\373", "u", txt, useBytes = TRUE)
txt <- gsub("\374", "u", txt, useBytes = TRUE)
txt <- gsub("\375", "y", txt, useBytes = TRUE)
txt <- gsub("\376", "t", txt, useBytes = TRUE)
txt <- gsub("\377", "y", txt, useBytes = TRUE)
txt <- gsub("\303\237", "AY", txt, useBytes = TRUE)
##
txt
}
read.rm5.csv <- function(file, sep = ",", quote = "\"",
title, numbers.in.labels = TRUE) {
##
selvar <- function(x, sel, value = NA) {
res <-
if (!is.null(x))
x[sel]
else value[sel]
res
}
##
numchar <- function(x) {
res <- as.numeric(as.character(x))
res
}
##
nachar <- function(x) {
res <- x
res[is.na(res)] <- ""
res
}
##
if (missing(title)) {
title <- strsplit(file, "\\.csv$")[[1]]
tmp <- strsplit(title, "\\/")
title <- tmp[[1]][length(tmp[[1]])]
}
##
## Check number of fields in input data file
##
if (length(unique(count.fields(file, sep = sep, quote = quote,
comment.char = ""))) != 1)
stop("Input file has different number of elements. ",
"Probably your export data file contains the field ",
"'Risk of bias tables'. Please create a new export data file in ",
"RevMan 5 without this field.")
##
tdata <- read.table(file, header = TRUE,
sep = sep, quote = quote,
comment.char = "")
##
nam <- names(tdata)
##
## Overcome problems to import files with UTF-8, byte order mark encoding
## (see http://en.wikipedia.org/wiki/Byte_order_mark)
##
nam[grep("Comparison.Number$", nam)] <- "Comparison.Number"
##
if (!all(c("Comparison.Number", "Outcome.Number",
"Subgroup.Number") %in% nam))
stop("Mandatory fields 'Comparison Number', 'Outcome Number',",
" and 'Subgroup Number' not included in export file ",
deparse(substitute(file)),
" (see help page of function read.rm5).")
##
nam[nam == "Comparison.Number"] <- "comp.no"
nam[nam == "Outcome.Number"] <- "outcome.no"
nam[nam == "Subgroup.Number"] <- "group.no"
nam[nam == "Name"] <- "author"
##
nam[nam == "Data.Type"] <- "type"
nam[nam == "Statistical.Method"] <- "method"
nam[nam == "Effect.Measure"] <- "sm"
nam[nam == "Analysis.Model"] <- "model"
##
## Variable 'Totals' not included in data frame
## Variable 'Study.Confidence.Interval' not included in data frame
## Variable 'Total.Confidence.Interval' not included in data frame
## Variable 'Test.for.subgroup.differences' not included in data frame
##
nam[nam == "Swap.event.and.non.event"] <- "swap.events"
nam[nam == "Entered.data.are.on.log.scale..Generic.Inverse.Variance.only."] <-
"logscale"
nam[nam == "Enter.number.of.participants..Generic.Inverse.Variance..for.display.only."] <-
"enter.n"
##
nam[nam == "Events.1"] <- "event.e"
nam[nam == "Mean.1"] <- "mean.e"
nam[nam == "SD.1"] <- "sd.e"
nam[nam == "Total.1"] <- "n.e"
##
nam[nam == "Events.2"] <- "event.c"
nam[nam == "Mean.2"] <- "mean.c"
nam[nam == "SD.2"] <- "sd.c"
nam[nam == "Total.2"] <- "n.c"
##
nam[nam == "O.E"] <- "O.E"
nam[nam == "Var"] <- "V"
##
nam[nam == "Effect.Estimate"] <- "TE"
nam[nam == "SE"] <- "seTE"
##
nam[nam == "CI.Start"] <- "lower"
nam[nam == "CI.End"] <- "upper"
##
nam[nam == "Weight"] <- "weight"
##
## Variable 'Q' is Q
nam[nam == "P.Q."] <- "pval.Q"
nam[nam == "I..Q."] <- "I2"
nam[nam == "Tau."] <- "tau2"
##
## Variable 'Z' is Z
nam[nam == "P.Z."] <- "pval.TE"
## Variable 'Qint' is Qint
nam[nam == "P.Qint."] <- "pval.Qint"
nam[nam == "I..Qint."] <- "I2.Qint"
## Variable 'df' is df
##
nam[nam == "Group.Label.1"] <- "label.e"
nam[nam == "Group.Label.2"] <- "label.c"
nam[nam == "Left.Graph.Label"] <- "label.left"
nam[nam == "Right.Graph.Label"] <- "label.right"
##
nam[nam == "Year.of.study"] <- "year"
nam[nam == "User.defined.order"] <- "order"
##
## Fancy coding to set variable names of I^2 and tau^2
## as "I2" and "tau2" (not necessary for Linux)
## I don't know how to do this differently with Windows ...
##
if (!all(c("I2", "tau2") %in% nam)) {
pos1 <- seq(along=nam)[nam == "pval.Q"]
pos2 <- seq(along=nam)[nam == "Z"]
if ((pos2 - pos1) == 3)
nam[pos1 + 1:2] <- c("I2", "tau2")
}
if (!"I2.Qint" %in% nam) {
pos3 <- seq(along=nam)[nam == "pval.Qint"]
pos4 <- seq(along=nam)[nam == "df"]
if ((pos4 - pos3) == 2)
nam[pos1 + 1] <- c("I2.Qint")
}
##
names(tdata) <- nam
##
tdata$author <- as.character(tdata$author)
tdata$type <- as.character(tdata$type)
tdata$method <- as.character(tdata$method)
tdata$method[tdata$method == "IV"] <- "Inverse"
tdata$sm <- as.character(tdata$sm)
tdata$model <- as.character(tdata$model)
tdata$common <- tdata$model == "Fixed"
tdata$random <- tdata$model == "Random"
##
tdata$sm <- em2sm(tdata$sm)
##
sel.oe <- tdata$method == "EXP_O_E_VAR"
tdata$method[sel.oe] <- "Peto"
tdata$sm[sel.oe] <- "OR"
##
sel.peto <- tdata$method == "PETO" & tdata$sm == "PETO_OR"
tdata$method[sel.peto] <- "Peto"
tdata$sm[sel.peto] <- "OR"
##
tdata$event.e <- as.numeric(gsub(",", "", tdata$event.e))
tdata$n.e <- as.numeric(gsub(",", "", tdata$n.e))
tdata$event.c <- as.numeric(gsub(",", "", tdata$event.c))
tdata$n.c <- as.numeric(gsub(",", "", tdata$n.c))
tdata$mean.e <- as.numeric(gsub(",", "", tdata$mean.e))
tdata$sd.e <- as.numeric(gsub(",", "", tdata$sd.e))
tdata$mean.c <- as.numeric(gsub(",", "", tdata$mean.c))
tdata$sd.c <- as.numeric(gsub(",", "", tdata$sd.c))
if (!is.null(tdata$O.E))
tdata$O.E <- as.numeric(gsub(",", "", tdata$O.E))
if (!is.null(tdata$V))
tdata$V <- as.numeric(gsub(",", "", tdata$V))
tdata$TE <- as.numeric(gsub(",", "", tdata$TE))
## No warning concerning infinite values for
## seTE, lower and upper CI bound
tdata$seTE <- suppressWarnings(as.numeric(gsub(",", "", tdata$seTE)))
tdata$lower <- suppressWarnings(as.numeric(gsub(",", "", tdata$lower)))
tdata$upper <- suppressWarnings(as.numeric(gsub(",", "", tdata$upper)))
##
tdata$weight <- as.numeric(gsub(",", "", tdata$weight))
tdata$Q <- as.numeric(gsub(",", "", tdata$Q))
tdata$tau2 <- as.numeric(gsub(",", "", tdata$tau2))
tdata$Qint <- as.numeric(gsub(",", "", tdata$Qint))
##
diffcomp <- c(1, diff(tdata$comp.no))
diffoutc <- c(1, diff(tdata$outcome.no))
diffgrp <- c(1, diff(tdata$group.no))
##
sel.comp <- diffcomp != 0
sel.outc <- diffoutc != 0 & !sel.comp
sel.grp <- tdata$type != "" & diffgrp != 0 & !sel.comp & !sel.outc
sel.study <- !sel.comp & !sel.outc & !sel.grp
##
res <- list(title = title,
comparison =
data.frame(comp.no = selvar(tdata$comp.no, sel.comp),
complab = selvar(tdata$author, sel.comp)
),
outcome =
data.frame(comp.no = selvar(tdata$comp.no, sel.outc),
outcome.no = selvar(tdata$outcome.no, sel.outc),
##
type = selvar(tdata$type, sel.outc),
method = selvar(tdata$method, sel.outc),
sm = selvar(tdata$sm, sel.outc),
model = selvar(tdata$model, sel.outc),
common = selvar(tdata$common, sel.outc),
random = selvar(tdata$random, sel.outc),
outclab = selvar(tdata$author, sel.outc),
##
k = selvar(tdata$df, sel.outc) + 1,
##
event.e.pooled = selvar(tdata$event.e, sel.outc),
n.e.pooled = selvar(tdata$n.e, sel.outc),
event.c.pooled = selvar(tdata$event.c, sel.outc),
n.c.pooled = selvar(tdata$n.c, sel.outc),
##
TE.pooled = selvar(tdata$TE, sel.outc),
lower.pooled = selvar(tdata$lower, sel.outc),
upper.pooled = selvar(tdata$upper, sel.outc),
##
weight.pooled = selvar(tdata$weight, sel.outc),
##
Z.pooled = selvar(tdata$Z, sel.outc),
pval.TE.pooled = selvar(tdata$pval.TE, sel.outc),
##
Q = selvar(tdata$Q, sel.outc),
pval.Q = selvar(tdata$pval.Q, sel.outc),
I2 = selvar(tdata$I2, sel.outc),
tau2 = selvar(tdata$tau2, sel.outc),
##
Q.w = selvar(tdata$Qint, sel.outc),
pval.Q.w = selvar(tdata$pval.Qint, sel.outc),
I2.w = selvar(tdata$I2.Qint, sel.outc),
##
swap.events = selvar(tdata$swap.events, sel.outc),
enter.n = selvar(tdata$enter.n, sel.outc),
logscale = selvar(tdata$logscale, sel.outc),
##
label.e = selvar(tdata$label.e, sel.outc),
label.c = selvar(tdata$label.c, sel.outc),
label.left = selvar(tdata$label.left, sel.outc),
label.right = selvar(tdata$label.right, sel.outc)
),
group =
if (sum(sel.grp) > 0 ) {
data.frame(comp.no = selvar(tdata$comp.no, sel.grp),
outcome.no = selvar(tdata$outcome.no, sel.grp),
group.no = selvar(tdata$group.no, sel.grp),
grplab = selvar(tdata$author, sel.grp)
)}
else {
NA
},
study =
data.frame(comp.no = selvar(tdata$comp.no, sel.study),
outcome.no = selvar(tdata$outcome.no, sel.study),
group.no = selvar(tdata$group.no, sel.study),
studlab = selvar(tdata$author, sel.study),
year = selvar(tdata$year, sel.study),
##
event.e = selvar(tdata$event.e, sel.study),
n.e = selvar(tdata$n.e, sel.study),
event.c = selvar(tdata$event.c, sel.study),
n.c = selvar(tdata$n.c, sel.study),
##
mean.e = selvar(tdata$mean.e, sel.study),
sd.e = selvar(tdata$sd.e, sel.study),
mean.c = selvar(tdata$mean.c, sel.study),
sd.c = selvar(tdata$sd.c, sel.study),
##
O.E = selvar(tdata$O.E, sel.study),
V = selvar(tdata$V, sel.study),
##
TE = selvar(tdata$TE, sel.study),
seTE = selvar(tdata$seTE, sel.study),
##
lower.TE = selvar(tdata$lower, sel.study),
upper.TE = selvar(tdata$upper, sel.study),
weight = selvar(tdata$weight, sel.study),
##
order = selvar(tdata$order, sel.study)
)
)
##
if (is.data.frame(res$group))
res2 <- merge(res$study, res$group,
by = c("comp.no", "outcome.no", "group.no"),
all.x = TRUE)
else
res2 <- res$study
res2 <- merge(res2, res$outcome,
by = c("comp.no", "outcome.no"))
res2 <- merge(res2, res$comparison,
by = c("comp.no"))
##
sel.nocont <- (res2$mean.e == 0 & res2$sd.e == 0 &
res2$mean.c == 0 & res2$sd.c == 0)
res2$mean.e[sel.nocont] <- NA
res2$sd.e[sel.nocont] <- NA
res2$mean.c[sel.nocont] <- NA
res2$sd.c[sel.nocont] <- NA
##
if (is.factor(res2$O.E))
res2$O.E <- numchar(res2$O.E)
if (is.factor(res2$V))
res2$V <- numchar(res2$V)
sel.noOE <- res2$O.E == 0 & res2$V == 0
res2$O.E[sel.noOE] <- NA
res2$V[sel.noOE] <- NA
##
res2$complab <- as.character(res2$complab)
res2$outclab <- nachar(as.character(res2$outclab))
res2$studlab <- nachar(as.character(res2$studlab))
if (is.data.frame(res$group)) {
res2$grplab <- nachar(as.character(res2$grplab))
## Replace some XML code:
res2$grplab <- gsub("\\<", "<", res2$grplab)
res2$grplab <- gsub("\\>", ">", res2$grplab)
}
##
res2$sm <- as.character(res2$sm)
res2$method <- as.character(res2$method)
res2$type <- substring(res2$type, 1, 1)
res2$model <- as.character(res2$model)
##
res2$label.e <- nachar(as.character(res2$label.e))
res2$label.c <- nachar(as.character(res2$label.c))
res2$label.left <- nachar(as.character(res2$label.left))
res2$label.right <- nachar(as.character(res2$label.right))
##
if (numbers.in.labels & length(res2$comp.no) > 0) {
res2$complab <- paste0(res2$comp.no, " ", res2$complab)
res2$outclab <- paste0(res2$comp.no, ".", res2$outcome.no, " ",
res2$outclab)
if (is.data.frame(res$group))
res2$grplab <- paste0(res2$comp.no, ".", res2$outcome.no, ".",
res2$group.no, " ", res2$grplab)
}
##
res2 <- res2[order(res2$comp.no,
res2$outcome.no,
res2$group.no),]
##
attr(res2, "title") <- res$title
##
if (length(res2$comp.no) > 0) {
for (i in unique(res2$comp.no)) {
for (j in unique(res2$outcome.no[res2$comp.no == i])) {
sel2 <- res2$comp.no == i & res2$outcome.no == j
if (unique(res2$sm[sel2]) == "OTHER")
warning("Summary measure unclear for outcome '",
##paste0(unique(res2$comp.no[sel2]), ".",
## unique(res2$outcome.no[sel2])),
unique(res2$outclab[sel2]),
"'. Please use argument 'sm' in function metacr ",
"to choose adequate summary measure.")
}
}
}
##res2$TE[res2$sm == "HR"] <- log(res2$TE[res2$sm == "HR"])
##res2$sm[res2$sm == "log HR"] <- "HR"
iswap.events <- charmatch(tolower(as.character(res2$swap.events)),
c("yes", "no"), nomatch = NA)
res2$swap.events <- ifelse(iswap.events == 1, TRUE,
ifelse(iswap.events == 2, FALSE, NA))
##
ienter.n <- charmatch(tolower(as.character(res2$enter.n)),
c("yes", "no"), nomatch = NA)
res2$enter.n <- ifelse(ienter.n == 1, TRUE,
ifelse(ienter.n == 2, FALSE, NA))
##
ilogscale <- charmatch(tolower(as.character(res2$logscale)),
c("no", "yes"), nomatch = NA)
res2$logscale <- ifelse(ilogscale == 1, TRUE,
ifelse(ilogscale == 2, FALSE, NA))
attr(res2, "version") <- packageDescription("meta")$Version
class(res2) <- c("rm5", "data.frame")
res2
}
read.rm5.rm5 <- function(file, title, numbers.in.labels = TRUE, debug = 0) {
##
## Read data file
##
rdata <- readLines(file, warn = FALSE)
##
## Convert extended ASCII codes
##
rdata <- oct2txt(rdata)
##
## Extract title
##
if (missing(title)) {
sel1 <- grep("<TITLE", rdata)
sel2 <- grep("</TITLE", rdata)
title.orig <- rdata[unique(c(sel1[1], sel2[1]))]
title <- xml_text(as_xml_document(paste(title.orig, collapse = " ")))
}
if (debug) {
cat("\n***** TITLE *****\n")
cat(paste0("Title: ", title, "\n"))
##
if (debug == 3)
print(title.orig)
}
##
## Determine whether study data are available
##
sel.data1 <- grepl("<ANALYSES_AND_DATA", rdata)
sel.data2 <- grepl("</ANALYSES_AND_DATA", rdata)
##
if (!any(sel.data2)) {
warning("Cochrane review does not contain any study data.",
call. = FALSE)
return(NULL)
}
##
sel.data1 <- grep("<ANALYSES_AND_DATA", rdata)
sel.data2 <- grep("</ANALYSES_AND_DATA", rdata)
##
## Extract data (as vector of character strings)
##
txt <- rdata[(sel.data1 + 1):(sel.data2 - 1)]
##
sel.data1 <- grepl("<DICH_DATA", txt)
sel.data2 <- grepl("<CONT_DATA", txt)
sel.data3 <- grepl("<IV_DATA", txt)
sel.data4 <- grepl("<IPD_DATA", txt)
##
if (!any(sel.data1 | sel.data2 | sel.data3 | sel.data4)) {
warning("Cochrane review does not contain any usable study data.",
call. = FALSE)
return(NULL)
}
res <- data.frame(comp.no = NA, outcome.no = NA, group.no = NA,
id = "",
event.e = NA, n.e = NA, event.c = NA, n.c = NA,
mean.e = NA, sd.e = NA, mean.c = NA, sd.c = NA,
O.E = NA, V = NA,
TE = NA, seTE = NA, lower.TE = NA, upper.TE = NA,
weight = NA, order = NA, level = NA,
grplab = "",
overall = NA,
test.subgroup = NA,
type = "", method = "", sm = "", model = "",
common = NA, random = NA,
outclab = "",
k = NA,
event.e.pooled = NA, n.e.pooled = NA,
event.c.pooled = NA, n.c.pooled = NA,
TE.pooled = NA, lower.pooled = NA, upper.pooled = NA,
level.ma = NA,
weight.pooled = NA,
Z.pooled = NA, pval.TE.pooled = NA,
Q = NA, pval.Q = NA,
I2 = NA, tau2 = NA,
Q.w = NA, pval.Q.w = NA, I2.w = NA,
swap.events = NA, logscale = NA,
label.e = "", label.c = "",
label.left = "", label.right = "",
complab = "")
##
##
## Comparisons
##
##
sel.comp1 <- grep("<COMPARISON", txt)
sel.comp2 <- grep("</COMPARISON", txt)
##
if (length(sel.comp1) != length(sel.comp2))
stop("Malformed XML file (tag: COMPARISON)")
##
for (i in seq(along = sel.comp1)) {
txt.i <- txt[sel.comp1[i]:sel.comp2[i]]
sel.data.i <- c(grep("</NAME>", txt.i))
if (length(sel.data.i) > 0)
sel.i <- c(1:(max(c(2, min(sel.data.i)))), length(txt.i))
else
sel.i <- c(1:2, length(txt.i))
##
xml.i <- as_xml_document(paste(txt.i[sel.i], collapse = " "))
##
comp.no <- as.numeric(xml_attr(xml.i, "NO"))
complab <- xml_text(xml_find_all(xml.i, "//NAME"))
##
if (debug) {
cat("\n**** COMPARISON ****\n")
cat(paste0("Comp.no: ", comp.no, "\n"))
cat(paste0("complab: ", complab, "\n"))
##
if (debug == 3)
print(txt.i[sel.i])
}
##
## Binary outcomes
##
res <- extract_outcomes(txt.i, "DICH", res,
comp.no, complab,
debug = debug)
##
## Continuous outcomes
##
res <- extract_outcomes(txt.i, "CONT", res,
comp.no, complab,
debug = debug)
##
## IV outcomes
##
res <- extract_outcomes(txt.i, "IV", res,
comp.no, complab,
debug = debug)
##
## IPD outcomes
##
res <- extract_outcomes(txt.i, "IPD", res,
comp.no, complab,
debug = debug)
}
##
res <- res[-1, ]
##
## Determine whether information on included studies are available
##
sel.incl1 <- grepl("<INCLUDED_STUDIES ", rdata) |
grepl("<INCLUDED_STUDIES>", rdata)
sel.incl2 <- grepl("</INCLUDED_STUDIES>", rdata)
##
if (any(sel.incl2)) {
##
## Extract study information (as vector of character strings)
##
sel.incl1 <- c(grep("<INCLUDED_STUDIES ", rdata),
grep("<INCLUDED_STUDIES>", rdata))
sel.incl2 <- grep("</INCLUDED_STUDIES>", rdata)
##
study <- rdata[(sel.incl1 + 1):(sel.incl2 - 1)]
##
sel.study1 <- grep("<STUDY", study)
sel.study2 <- grep("</STUDY", study)
##
id <- studlab <- year <- rep("", length(sel.study1))
##
if ((length(sel.study1) > 0 | length(sel.study2) > 0) &&
(length(sel.study1) == length(sel.study2))) {
if (debug)
cat(paste0("\n* STUDY *\n"))
for (s in seq(along = sel.study1)) {
study.s <- study[sel.study1[s]:sel.study2[s]]
xml.s <- as_xml_document(paste(study.s, collapse = " "))
##
id[s] <- xml_attr(xml.s, "ID")
studlab[s] <- xml_attr(xml.s, "NAME")
year[s] <- xml_attr(xml.s, "YEAR")
##
if (debug >= 2) {
cat("- id:\n")
print(id)
cat("- studlab:\n")
print(studlab)
cat("- year:\n")
print(year)
##
if (debug == 3)
print(study.s)
}
}
##
names.res <- names(res)
res.study <- data.frame(id, studlab, year)
res <- merge(res, res.study, by = "id",
all.x = TRUE)
##
names.res <- c(names.res[1:4], "studlab", "year",
names.res[5:length(names.res)])
##
res <- res[, names.res]
}
}
res <- res[order(res$comp.no, res$outcome.no, res$group.no), ]
##
if (numbers.in.labels & length(res$comp.no) > 0) {
res$complab <- paste0(res$comp.no, " ", res$complab)
res$outclab <- paste0(res$comp.no, ".", res$outcome.no, " ",
res$outclab)
sel.grp <- !is.na(res$group.no)
if (any(sel.grp))
res$grplab[sel.grp] <-
paste0(res$comp.no, ".", res$outcome.no, ".",
res$group.no, " ", res$grplab)[sel.grp]
}
##
res$test.subgroup[is.na(res$group.no)] <- NA
##
row.names(res) <- 1:nrow(res)
##
res$id <- as.character(res$id)
res$studlab <- as.character(res$studlab)
res$year <- as.character(res$year)
res$grplab <- as.character(res$grplab)
res$type <- as.character(res$type)
res$method <- as.character(res$method)
res$sm <- as.character(res$sm)
res$model <- as.character(res$model)
res$label.e <- as.character(res$label.e)
res$label.c <- as.character(res$label.c)
res$label.left <- as.character(res$label.left)
res$label.right <- as.character(res$label.right)
##
## sel.rel <- is_relative_effect(res$sm)
## res$TE[sel.rel] <- log(res$TE[sel.rel])
## res$lower.TE[sel.rel] <- log(res$lower.TE[sel.rel])
## res$upper.TE[sel.rel] <- log(res$upper.TE[sel.rel])
## res$seTE <- TE.seTE.ci(res$lower.TE, res$upper.TE, res$level)$seTE
##
res$fixed <- res$common
##
attr(res, "title") <- title
attr(res, "version") <- packageDescription("meta")$Version
class(res) <- c("rm5", "data.frame")
res
}
guido-s/meta documentation built on April 18, 2024, 7:11 p.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.
Defines functions read.rm5.rm5 read.rm5.csv oct2txt extract_outcomes
##
##
## Definition of auxiliary functions to import RevMan 5 analysis datasets
##
##
extract_outcomes <- function(txt, outcome.type, res,
comp.no, complab,
debug = 0) {
##
pattern1 <- paste0("<", outcome.type, "_OUTCOME")
pattern2 <- paste0("</", outcome.type, "_OUTCOME")
sel1 <- grep(pattern1, txt)
sel2 <- grep(pattern2, txt)
##
if (length(sel1) > 0 | length(sel2) > 0) {
##
if (debug)
cat(paste0("\n*** ", outcome.type, "_OUTCOME ***\n"))
##
if (length(sel1) != length(sel2))
stop("Malformed XML file (tag: ", outcome.type, "_OUTCOME)")
##
for (j in seq(along = sel1)) {
txt.j <- txt[sel1[j]:sel2[j]]
sel.data.j <- c(grep(paste0("<", outcome.type, "_DATA"), txt.j) - 1,
grep(paste0("<", outcome.type, "_SUBGROUP"), txt.j) - 1)
if (outcome.type %in% c("IV", "IPD"))
sel.data.j <- c(sel.data.j, grep("</EFFECT_MEASURE>", txt.j))
else
sel.data.j <- c(sel.data.j, grep("</GRAPH_LABEL_2>", txt.j))
if (length(sel.data.j) > 0)
sel.j <- c(1:(max(c(6, min(sel.data.j)))), length(txt.j))
else
sel.j <- c(1:6, length(txt.j))
##
xml.j <- as_xml_document(paste(txt.j[sel.j], collapse = " "))
##
outcome.no <- as.numeric(xml_attr(xml.j, "NO"))
outclab <- xml_text(xml_find_all(xml.j, "//NAME"))
##
if (debug) {
cat(paste0("Outcome.no: ", outcome.no, "\n"))
cat(paste0("outclab: ", outclab, "\n"))
##
if (debug == 3)
print(txt.j[sel.j])
}
##
overall <- xml_attr(xml.j, "TOTALS") == "YES"
test.subgroup <- xml_attr(xml.j, "SUBGROUP_TEST") == "YES"
##
n.studies <- as.numeric(xml_attr(xml.j, "DF")) + 1
##
type <- switch(outcome.type,
DICH = "D",
CONT = "C",
IV = "I",
IPD = "I")
##
method <- xml_attr(xml.j, "METHOD")
if (is.na(method) & outcome.type == "IPD")
method <- "Peto"
else if (is.na(method))
method <- "Inverse"
else if (method == "IV")
method <- "Inverse"
##
sm <- xml_attr(xml.j, "EFFECT_MEASURE")
if (is.na(sm)) {
sm <- xml_text(xml_find_all(xml.j, "//EFFECT_MEASURE"))
sm[tolower(sm) == "odds ratio"] <- "OR"
sm[tolower(sm) == "peto odds ratio"] <- "OR"
sm[tolower(sm) == "peto_or"] <- "OR"
sm[tolower(sm) == "odds ratio (non-event)"] <- "OR"
sm[tolower(sm) == "risk ratio"] <- "RR"
sm[tolower(sm) == "risk difference"] <- "RD"
sm[tolower(sm) == "mean difference"] <- "MD"
sm[tolower(sm) == "standardized mean difference"] <- "SMD"
sm[tolower(sm) == "std. mean difference"] <- "SMD"
sm[tolower(sm) == "hazard ratio"] <- "HR"
}
##
logscale <- xml_attr(xml.j, "LOG_DATA") == "NO"
##
random <- xml_attr(xml.j, "RANDOM")
if (is.na(random) & outcome.type == "IPD")
random <- "NO"
model <- ifelse(random == "NO", "Fixed", "Random")
common <- model == "Fixed"
random <- model == "Random"
##
TE.pooled <- as.numeric(xml_attr(xml.j, "EFFECT_SIZE"))
lower.pooled <- as.numeric(xml_attr(xml.j, "CI_START"))
upper.pooled <- as.numeric(xml_attr(xml.j, "CI_END"))
weight.pooled <- as.numeric(xml_attr(xml.j, "WEIGHT"))
level <- as.numeric(xml_attr(xml.j, "CI_STUDY")) / 100
level.ma <- as.numeric(xml_attr(xml.j, "CI_TOTAL")) / 100
##
Z.pooled <- as.numeric(xml_attr(xml.j, "Z"))
pval.TE.pooled <- as.numeric(xml_attr(xml.j, "P_Z"))
Q <- as.numeric(xml_attr(xml.j, "Q"))
pval.Q <- as.numeric(xml_attr(xml.j, "P_Q"))
I2 <- as.numeric(xml_attr(xml.j, "I2"))
tau2 <- as.numeric(xml_attr(xml.j, "TAU2"))
##
event.e.pooled <- as.numeric(xml_attr(xml.j, "EVENTS_1"))
n.e.pooled <- as.numeric(xml_attr(xml.j, "TOTAL_1"))
event.c.pooled <- as.numeric(xml_attr(xml.j, "EVENTS_2"))
n.c.pooled <- as.numeric(xml_attr(xml.j, "TOTAL_2"))
##
swap.events <- xml_attr(xml.j, "SWAP_EVENTS") != "NO"
##
label.e <- xml_text(xml_find_all(xml.j, "//GROUP_LABEL_1"))
label.c <- xml_text(xml_find_all(xml.j, "//GROUP_LABEL_2"))
label.left <- xml_text(xml_find_all(xml.j, "//GRAPH_LABEL_1"))
label.right <- xml_text(xml_find_all(xml.j, "//GRAPH_LABEL_2"))
##
## Subgroups
##
sel.subgroup1 <- grep(paste0("<", outcome.type, "_SUBGROUP"), txt.j)
sel.subgroup2 <- grep(paste0("</", outcome.type, "_SUBGROUP"), txt.j)
##
if (length(sel.subgroup1 > 0) | length(sel.subgroup2) > 0) {
if (debug)
cat(paste0("\n** ", outcome.type, "_SUBGROUP **\n"))
##
if (length(sel.subgroup1) != length(sel.subgroup2))
stop("Malformed XML file (tag: ", outcome.type, "_SUBGROUP)")
##
for (k in seq(along = sel.subgroup1)) {
txt.jk <- txt.j[sel.subgroup1[k]:sel.subgroup2[k]]
sel.data.jk <- c(grep(paste0("<", outcome.type, "_DATA"), txt.jk) - 1,
grep("</NAME>", txt.jk))
if (length(sel.data.jk) > 0)
sel.jk <- unique(c(1:(max(c(2, min(sel.data.jk)))), length(txt.jk)))
else
sel.jk <- unique(c(1:2, length(txt.jk)))
##
xml.jk <- as_xml_document(paste(txt.jk[sel.jk], collapse = " "))
##
group.no <- as.numeric(xml_attr(xml.jk, "NO"))
grplab <- xml_text(xml_find_all(xml.jk, "//NAME"))
##
if (debug) {
cat(paste0("Group.no: ", group.no, "\n"))
cat(paste0("grplab: ", grplab, "\n"))
##
if (debug == 3)
print(txt.jk[sel.jk])
}
##
Q.w <- as.numeric(xml_attr(xml.jk, "NO"))
pval.Q.w <- as.numeric(xml_attr(xml.jk, "P_CHI2"))
I2.w <- as.numeric(xml_attr(xml.jk, "I2"))
##
## Data
##
sel.data1 <- grep(paste0("<", outcome.type, "_DATA"), txt.jk)
##
sel1.data2 <- grepl("/>", txt.jk)
sel2.data2 <- grepl(paste0("</", outcome.type, "_DATA"), txt.jk)
sel3.data2 <-
!(grepl("<GROUP_LABEL", txt.jk) |
grepl("<GRAPH_LABEL", txt.jk) |
grepl("<EFFECT_MEASURE", txt.jk))
sel.data2 <-
seq_along(txt.jk)[(sel1.data2 | sel2.data2) & sel3.data2]
##
if (length(sel.data1) != length(sel.data2)) {
if (debug == 3) {
print(txt.jk)
cat(paste0("sel.data1: ", sel.data1, "\n"))
cat(paste0("sel.data2: ", sel.data2, "\n"))
##
print(data.frame(sel1.data2, sel2.data2, sel3.data2))
}
stop("Malformed XML file (tag: ", outcome.type, "_DATA)")
}
##
event.e <- n.e <- event.c <- n.c <-
mean.e <- sd.e <- mean.c <- sd.c <-
O.E <- V <-
TE <- seTE <- lower.TE <- upper.TE <-
weight <- order <-
rep(NA, length(sel.data1))
##
id <- rep("", length(sel.data1))
##
if (length(sel.data1) > 0) {
if (debug)
cat(paste0("\n* ", outcome.type, "_DATA *\n"))
for (l in seq(along = sel.data1)) {
txt.jkl <- paste(txt.jk[sel.data1[l]:sel.data2[l]],
collapse = "")
##
if (debug == 3)
print(txt.jk[sel.data1[l]:sel.data2[l]])
##
xml.jkl <- as_xml_document(txt.jkl)
##
id[l] <- xml_attr(xml.jkl, "STUDY_ID")
##
event.e[l] <- as.numeric(xml_attr(xml.jkl, "EVENTS_1"))
n.e[l] <- as.numeric(xml_attr(xml.jkl, "TOTAL_1"))
mean.e[l] <- as.numeric(xml_attr(xml.jkl, "MEAN_1"))
sd.e[l] <- as.numeric(xml_attr(xml.jkl, "SD_1"))
##
event.c[l] <- as.numeric(xml_attr(xml.jkl, "EVENTS_2"))
n.c[l] <- as.numeric(xml_attr(xml.jkl, "TOTAL_2"))
mean.c[l] <- as.numeric(xml_attr(xml.jkl, "MEAN_2"))
sd.c[l] <- as.numeric(xml_attr(xml.jkl, "SD_2"))
##
O.E[l] <- as.numeric(xml_attr(xml.jkl, "O_E"))
V[l] <- as.numeric(xml_attr(xml.jkl, "VAR"))
##
TE[l] <- as.numeric(xml_attr(xml.jkl, "EFFECT_SIZE"))
seTE[l] <- as.numeric(xml_attr(xml.jkl, "SE"))
lower.TE[l] <- as.numeric(xml_attr(xml.jkl, "CI_START"))
upper.TE[l] <- as.numeric(xml_attr(xml.jkl, "CI_END"))
##
weight[l] <- as.numeric(xml_attr(xml.jkl, "WEIGHT"))
order[l] <- as.numeric(xml_attr(xml.jkl, "ORDER"))
}
##
res.new <-
data.frame(comp.no, outcome.no, group.no,
id = id,
event.e = event.e, n.e = n.e,
event.c = event.c, n.c = n.c,
mean.e = mean.e, sd.e = sd.e,
mean.c = mean.c, sd.c = sd.c,
O.E = O.E, V = V,
TE = TE, seTE = seTE,
lower.TE = lower.TE, upper.TE = upper.TE,
weight = weight, order = order,
level = level,
grplab = grplab,
overall = overall,
test.subgroup = test.subgroup,
type = type, method = method, sm = sm, model = model,
common = common, random = random,
outclab = outclab,
k = n.studies,
event.e.pooled = event.e.pooled,
n.e.pooled = n.e.pooled,
event.c.pooled = event.c.pooled,
n.c.pooled = n.c.pooled,
TE.pooled = TE.pooled,
lower.pooled = lower.pooled,
upper.pooled = upper.pooled,
weight.pooled = weight.pooled,
level.ma = level.ma,
Z.pooled = Z.pooled, pval.TE.pooled = pval.TE.pooled,
Q = Q, pval.Q = pval.Q,
I2 = I2, tau2 = tau2,
Q.w = Q.w, pval.Q.w = pval.Q.w, I2.w = I2.w,
swap.events = swap.events, logscale = logscale,
label.e = label.e, label.c = label.c,
label.left = label.left,
label.right = label.right,
complab = complab)
##
if (debug >= 2) {
cat("\n* New data: *\n")
print(res.new)
}
res <- rbind(res, res.new)
}
}
}
else {
group.no <- NA
grplab <- ""
Q.w <- NA
pval.Q.w <- NA
I2.w <- NA
##
## Data
##
sel.data1 <- grep(paste0("<", outcome.type, "_DATA"), txt.j)
##
sel1.data2 <- grepl("/>", txt.j)
sel2.data2 <- grepl(paste0("</", outcome.type, "_DATA"), txt.j)
sel3.data2 <-
!(grepl("<GROUP_LABEL", txt.j) |
grepl("<GRAPH_LABEL", txt.j) |
grepl("<EFFECT_MEASURE", txt.j))
sel.data2 <-
seq_along(txt.j)[(sel1.data2 | sel2.data2) & sel3.data2]
##
if (length(sel.data1) != length(sel.data2)) {
if (debug == 3) {
print(txt.j)
cat(paste0("sel.data1: ", sel.data1, "\n"))
cat(paste0("sel.data2: ", sel.data2, "\n"))
##
print(data.frame(sel1.data2, sel2.data2, sel3.data2))
}
stop("Malformed XML file (tag: ", outcome.type, "_DATA)")
}
##
event.e <- n.e <- event.c <- n.c <-
mean.e <- sd.e <- mean.c <- sd.c <-
O.E <- V <-
TE <- seTE <- lower.TE <- upper.TE <-
weight <- order <-
rep(NA, length(sel.data1))
##
id <- rep("", length(sel.data1))
##
if (length(sel.data1) > 0) {
if (debug) {
cat(paste0("\n* ", outcome.type, "_DATA *\n"))
print(sel.data1)
}
##
for (k in seq(along = sel.data1)) {
txt.jk <- paste(txt.j[sel.data1[k]:sel.data2[k]], collapse = "")
##
if (debug == 3)
print(txt.j[sel.data1[k]:sel.data2[k]])
##
xml.jk <- as_xml_document(txt.jk)
##
id[k] <- xml_attr(xml.jk, "STUDY_ID")
##
event.e[k] <- as.numeric(xml_attr(xml.jk, "EVENTS_1"))
n.e[k] <- as.numeric(xml_attr(xml.jk, "TOTAL_1"))
mean.e[k] <- as.numeric(xml_attr(xml.jk, "MEAN_1"))
sd.e[k] <- as.numeric(xml_attr(xml.jk, "SD_1"))
##
event.c[k] <- as.numeric(xml_attr(xml.jk, "EVENTS_2"))
n.c[k] <- as.numeric(xml_attr(xml.jk, "TOTAL_2"))
mean.c[k] <- as.numeric(xml_attr(xml.jk, "MEAN_2"))
sd.c[k] <- as.numeric(xml_attr(xml.jk, "SD_2"))
##
O.E[k] <- as.numeric(xml_attr(xml.jk, "O_E"))
V[k] <- as.numeric(xml_attr(xml.jk, "VAR"))
##
TE[k] <- as.numeric(xml_attr(xml.jk, "EFFECT_SIZE"))
seTE[k] <- as.numeric(xml_attr(xml.jk, "SE"))
lower.TE[k] <- as.numeric(xml_attr(xml.jk, "CI_START"))
upper.TE[k] <- as.numeric(xml_attr(xml.jk, "CI_END"))
##
weight[k] <- as.numeric(xml_attr(xml.jk, "WEIGHT"))
order[k] <- as.numeric(xml_attr(xml.jk, "ORDER"))
}
##
res.new <-
data.frame(comp.no, outcome.no, group.no,
id = id,
event.e = event.e, n.e = n.e,
event.c = event.c, n.c = n.c,
mean.e = mean.e, sd.e = sd.e,
mean.c = mean.c, sd.c = sd.c,
O.E = O.E, V = V,
TE = TE, seTE = seTE,
lower.TE = lower.TE, upper.TE = upper.TE,
weight = weight, order = order,
level = level,
grplab = grplab,
overall = overall,
test.subgroup = test.subgroup,
type = type, method = method, sm = sm, model = model,
common = common, random = random,
outclab = outclab,
k = n.studies,
event.e.pooled = event.e.pooled,
n.e.pooled = n.e.pooled,
event.c.pooled = event.c.pooled,
n.c.pooled = n.c.pooled,
TE.pooled = TE.pooled,
lower.pooled = lower.pooled,
upper.pooled = upper.pooled,
weight.pooled = weight.pooled,
level.ma = level.ma,
Z.pooled = Z.pooled, pval.TE.pooled = pval.TE.pooled,
Q = Q, pval.Q = pval.Q,
I2 = I2, tau2 = tau2,
Q.w = Q.w, pval.Q.w = pval.Q.w, I2.w = I2.w,
swap.events = swap.events, logscale = logscale,
label.e = label.e, label.c = label.c,
label.left = label.left,
label.right = label.right,
complab = complab)
##
if (debug >= 2) {
cat("\n* New data: *\n")
print(res.new)
}
##
res <- rbind(res, res.new)
}
}
}
}
##
res
}
oct2txt <- function(txt) {
txt <- gsub("\200", "EUR", txt, useBytes = TRUE)
txt <- gsub("\202", "'", txt, useBytes = TRUE)
txt <- gsub("\203", "f", txt, useBytes = TRUE)
txt <- gsub("\204", '"', txt, useBytes = TRUE)
txt <- gsub("\205", "...", txt, useBytes = TRUE)
txt <- gsub("\206", "+", txt, useBytes = TRUE)
txt <- gsub("\207", "+", txt, useBytes = TRUE)
txt <- gsub("\210", "^", txt, useBytes = TRUE)
txt <- gsub("\211", "%%", txt, useBytes = TRUE)
txt <- gsub("\212", "S", txt, useBytes = TRUE)
txt <- gsub("\213", "'", txt, useBytes = TRUE)
txt <- gsub("\214", "OE", txt, useBytes = TRUE)
txt <- gsub("\216", "Z", txt, useBytes = TRUE)
txt <- gsub("\221", "'", txt, useBytes = TRUE)
txt <- gsub("\222", "'", txt, useBytes = TRUE)
txt <- gsub("\223", '"', txt, useBytes = TRUE)
txt <- gsub("\224", '"', txt, useBytes = TRUE)
txt <- gsub("\225", "-", txt, useBytes = TRUE)
txt <- gsub("\226", "-", txt, useBytes = TRUE)
txt <- gsub("\227", "-", txt, useBytes = TRUE)
txt <- gsub("\230", "~", txt, useBytes = TRUE)
txt <- gsub("\231", "TM", txt, useBytes = TRUE)
txt <- gsub("\232", "S", txt, useBytes = TRUE)
txt <- gsub("\233", "'", txt, useBytes = TRUE)
txt <- gsub("\234", "oe", txt, useBytes = TRUE)
txt <- gsub("\237", "Y", txt, useBytes = TRUE)
txt <- gsub("\240", " ", txt, useBytes = TRUE)
txt <- gsub("\241", "!", txt, useBytes = TRUE)
txt <- gsub("\242", "cent", txt, useBytes = TRUE)
txt <- gsub("\243", "Pound", txt, useBytes = TRUE)
txt <- gsub("\244", "C", txt, useBytes = TRUE)
txt <- gsub("\245", "Yen", txt, useBytes = TRUE)
txt <- gsub("\246", "|", txt, useBytes = TRUE)
txt <- gsub("\247", "S", txt, useBytes = TRUE)
txt <- gsub("\250", "", txt, useBytes = TRUE)
txt <- gsub("\251", "(C)", txt, useBytes = TRUE)
txt <- gsub("\252", "", txt, useBytes = TRUE)
txt <- gsub("\253", "'", txt, useBytes = TRUE)
txt <- gsub("\254", "-", txt, useBytes = TRUE)
txt <- gsub("\255", "-", txt, useBytes = TRUE)
txt <- gsub("\256", "(R)", txt, useBytes = TRUE)
txt <- gsub("\257", "-", txt, useBytes = TRUE)
txt <- gsub("\260", "o", txt, useBytes = TRUE)
txt <- gsub("\261", "+/-", txt, useBytes = TRUE)
txt <- gsub("\262", "2", txt, useBytes = TRUE)
txt <- gsub("\263", "3", txt, useBytes = TRUE)
txt <- gsub("\264", "", txt, useBytes = TRUE)
txt <- gsub("\265", "mu", txt, useBytes = TRUE)
txt <- gsub("\266", "", txt, useBytes = TRUE)
txt <- gsub("\267", ".", txt, useBytes = TRUE)
txt <- gsub("\270", " ", txt, useBytes = TRUE)
txt <- gsub("\271", "1", txt, useBytes = TRUE)
txt <- gsub("\272", "o", txt, useBytes = TRUE)
txt <- gsub("\273", '"', txt, useBytes = TRUE)
txt <- gsub("\274", "1/4", txt, useBytes = TRUE)
txt <- gsub("\275", "1/2", txt, useBytes = TRUE)
txt <- gsub("\276", "3/4", txt, useBytes = TRUE)
txt <- gsub("\277", "?", txt, useBytes = TRUE)
txt <- gsub("\300", "A", txt, useBytes = TRUE)
txt <- gsub("\301", "A", txt, useBytes = TRUE)
txt <- gsub("\302", "A", txt, useBytes = TRUE)
txt <- gsub("\303", "A", txt, useBytes = TRUE)
txt <- gsub("\304", "A", txt, useBytes = TRUE)
txt <- gsub("\305", "A", txt, useBytes = TRUE)
txt <- gsub("\306", "AE", txt, useBytes = TRUE)
txt <- gsub("\307", "C", txt, useBytes = TRUE)
txt <- gsub("\310", "E", txt, useBytes = TRUE)
txt <- gsub("\311", "E", txt, useBytes = TRUE)
txt <- gsub("\312", "E", txt, useBytes = TRUE)
txt <- gsub("\313", "E", txt, useBytes = TRUE)
txt <- gsub("\314", "I", txt, useBytes = TRUE)
txt <- gsub("\315", "I", txt, useBytes = TRUE)
txt <- gsub("\316", "I", txt, useBytes = TRUE)
txt <- gsub("\317", "I", txt, useBytes = TRUE)
txt <- gsub("\320", "E", txt, useBytes = TRUE)
txt <- gsub("\321", "N", txt, useBytes = TRUE)
txt <- gsub("\322", "O", txt, useBytes = TRUE)
txt <- gsub("\323", "O", txt, useBytes = TRUE)
txt <- gsub("\324", "O", txt, useBytes = TRUE)
txt <- gsub("\325", "O", txt, useBytes = TRUE)
txt <- gsub("\326", "O", txt, useBytes = TRUE)
txt <- gsub("\327", "x", txt, useBytes = TRUE)
txt <- gsub("\330", "O", txt, useBytes = TRUE)
txt <- gsub("\331", "U", txt, useBytes = TRUE)
txt <- gsub("\332", "U", txt, useBytes = TRUE)
txt <- gsub("\333", "U", txt, useBytes = TRUE)
txt <- gsub("\334", "U", txt, useBytes = TRUE)
txt <- gsub("\335", "Y", txt, useBytes = TRUE)
txt <- gsub("\336", "T", txt, useBytes = TRUE)
txt <- gsub("\337", "ss", txt, useBytes = TRUE)
txt <- gsub("\340", "a", txt, useBytes = TRUE)
txt <- gsub("\341", "a", txt, useBytes = TRUE)
txt <- gsub("\342", "a", txt, useBytes = TRUE)
txt <- gsub("\343", "a", txt, useBytes = TRUE)
txt <- gsub("\344", "a", txt, useBytes = TRUE)
txt <- gsub("\345", "a", txt, useBytes = TRUE)
txt <- gsub("\346", "a", txt, useBytes = TRUE)
txt <- gsub("\347", "c", txt, useBytes = TRUE)
txt <- gsub("\350", "e", txt, useBytes = TRUE)
txt <- gsub("\351", "e", txt, useBytes = TRUE)
txt <- gsub("\352", "e", txt, useBytes = TRUE)
txt <- gsub("\353", "e", txt, useBytes = TRUE)
txt <- gsub("\354", "i", txt, useBytes = TRUE)
txt <- gsub("\355", "i", txt, useBytes = TRUE)
txt <- gsub("\356", "i", txt, useBytes = TRUE)
txt <- gsub("\357", "i", txt, useBytes = TRUE)
txt <- gsub("\360", "e", txt, useBytes = TRUE)
txt <- gsub("\361", "n", txt, useBytes = TRUE)
txt <- gsub("\362", "o", txt, useBytes = TRUE)
txt <- gsub("\363", "o", txt, useBytes = TRUE)
txt <- gsub("\364", "o", txt, useBytes = TRUE)
txt <- gsub("\365", "o", txt, useBytes = TRUE)
txt <- gsub("\366", "o", txt, useBytes = TRUE)
txt <- gsub("\367", "/", txt, useBytes = TRUE)
txt <- gsub("\370", "o", txt, useBytes = TRUE)
txt <- gsub("\371", "u", txt, useBytes = TRUE)
txt <- gsub("\372", "u", txt, useBytes = TRUE)
txt <- gsub("\373", "u", txt, useBytes = TRUE)
txt <- gsub("\374", "u", txt, useBytes = TRUE)
txt <- gsub("\375", "y", txt, useBytes = TRUE)
txt <- gsub("\376", "t", txt, useBytes = TRUE)
txt <- gsub("\377", "y", txt, useBytes = TRUE)
txt <- gsub("\303\237", "AY", txt, useBytes = TRUE)
##
txt
}
read.rm5.csv <- function(file, sep = ",", quote = "\"",
title, numbers.in.labels = TRUE) {
##
selvar <- function(x, sel, value = NA) {
res <-
if (!is.null(x))
x[sel]
else value[sel]
res
}
##
numchar <- function(x) {
res <- as.numeric(as.character(x))
res
}
##
nachar <- function(x) {
res <- x
res[is.na(res)] <- ""
res
}
##
if (missing(title)) {
title <- strsplit(file, "\\.csv$")[[1]]
tmp <- strsplit(title, "\\/")
title <- tmp[[1]][length(tmp[[1]])]
}
##
## Check number of fields in input data file
##
if (length(unique(count.fields(file, sep = sep, quote = quote,
comment.char = ""))) != 1)
stop("Input file has different number of elements. ",
"Probably your export data file contains the field ",
"'Risk of bias tables'. Please create a new export data file in ",
"RevMan 5 without this field.")
##
tdata <- read.table(file, header = TRUE,
sep = sep, quote = quote,
comment.char = "")
##
nam <- names(tdata)
##
## Overcome problems to import files with UTF-8, byte order mark encoding
## (see http://en.wikipedia.org/wiki/Byte_order_mark)
##
nam[grep("Comparison.Number$", nam)] <- "Comparison.Number"
##
if (!all(c("Comparison.Number", "Outcome.Number",
"Subgroup.Number") %in% nam))
stop("Mandatory fields 'Comparison Number', 'Outcome Number',",
" and 'Subgroup Number' not included in export file ",
deparse(substitute(file)),
" (see help page of function read.rm5).")
##
nam[nam == "Comparison.Number"] <- "comp.no"
nam[nam == "Outcome.Number"] <- "outcome.no"
nam[nam == "Subgroup.Number"] <- "group.no"
nam[nam == "Name"] <- "author"
##
nam[nam == "Data.Type"] <- "type"
nam[nam == "Statistical.Method"] <- "method"
nam[nam == "Effect.Measure"] <- "sm"
nam[nam == "Analysis.Model"] <- "model"
##
## Variable 'Totals' not included in data frame
## Variable 'Study.Confidence.Interval' not included in data frame
## Variable 'Total.Confidence.Interval' not included in data frame
## Variable 'Test.for.subgroup.differences' not included in data frame
##
nam[nam == "Swap.event.and.non.event"] <- "swap.events"
nam[nam == "Entered.data.are.on.log.scale..Generic.Inverse.Variance.only."] <-
"logscale"
nam[nam == "Enter.number.of.participants..Generic.Inverse.Variance..for.display.only."] <-
"enter.n"
##
nam[nam == "Events.1"] <- "event.e"
nam[nam == "Mean.1"] <- "mean.e"
nam[nam == "SD.1"] <- "sd.e"
nam[nam == "Total.1"] <- "n.e"
##
nam[nam == "Events.2"] <- "event.c"
nam[nam == "Mean.2"] <- "mean.c"
nam[nam == "SD.2"] <- "sd.c"
nam[nam == "Total.2"] <- "n.c"
##
nam[nam == "O.E"] <- "O.E"
nam[nam == "Var"] <- "V"
##
nam[nam == "Effect.Estimate"] <- "TE"
nam[nam == "SE"] <- "seTE"
##
nam[nam == "CI.Start"] <- "lower"
nam[nam == "CI.End"] <- "upper"
##
nam[nam == "Weight"] <- "weight"
##
## Variable 'Q' is Q
nam[nam == "P.Q."] <- "pval.Q"
nam[nam == "I..Q."] <- "I2"
nam[nam == "Tau."] <- "tau2"
##
## Variable 'Z' is Z
nam[nam == "P.Z."] <- "pval.TE"
## Variable 'Qint' is Qint
nam[nam == "P.Qint."] <- "pval.Qint"
nam[nam == "I..Qint."] <- "I2.Qint"
## Variable 'df' is df
##
nam[nam == "Group.Label.1"] <- "label.e"
nam[nam == "Group.Label.2"] <- "label.c"
nam[nam == "Left.Graph.Label"] <- "label.left"
nam[nam == "Right.Graph.Label"] <- "label.right"
##
nam[nam == "Year.of.study"] <- "year"
nam[nam == "User.defined.order"] <- "order"
##
## Fancy coding to set variable names of I^2 and tau^2
## as "I2" and "tau2" (not necessary for Linux)
## I don't know how to do this differently with Windows ...
##
if (!all(c("I2", "tau2") %in% nam)) {
pos1 <- seq(along=nam)[nam == "pval.Q"]
pos2 <- seq(along=nam)[nam == "Z"]
if ((pos2 - pos1) == 3)
nam[pos1 + 1:2] <- c("I2", "tau2")
}
if (!"I2.Qint" %in% nam) {
pos3 <- seq(along=nam)[nam == "pval.Qint"]
pos4 <- seq(along=nam)[nam == "df"]
if ((pos4 - pos3) == 2)
nam[pos1 + 1] <- c("I2.Qint")
}
##
names(tdata) <- nam
##
tdata$author <- as.character(tdata$author)
tdata$type <- as.character(tdata$type)
tdata$method <- as.character(tdata$method)
tdata$method[tdata$method == "IV"] <- "Inverse"
tdata$sm <- as.character(tdata$sm)
tdata$model <- as.character(tdata$model)
tdata$common <- tdata$model == "Fixed"
tdata$random <- tdata$model == "Random"
##
tdata$sm <- em2sm(tdata$sm)
##
sel.oe <- tdata$method == "EXP_O_E_VAR"
tdata$method[sel.oe] <- "Peto"
tdata$sm[sel.oe] <- "OR"
##
sel.peto <- tdata$method == "PETO" & tdata$sm == "PETO_OR"
tdata$method[sel.peto] <- "Peto"
tdata$sm[sel.peto] <- "OR"
##
tdata$event.e <- as.numeric(gsub(",", "", tdata$event.e))
tdata$n.e <- as.numeric(gsub(",", "", tdata$n.e))
tdata$event.c <- as.numeric(gsub(",", "", tdata$event.c))
tdata$n.c <- as.numeric(gsub(",", "", tdata$n.c))
tdata$mean.e <- as.numeric(gsub(",", "", tdata$mean.e))
tdata$sd.e <- as.numeric(gsub(",", "", tdata$sd.e))
tdata$mean.c <- as.numeric(gsub(",", "", tdata$mean.c))
tdata$sd.c <- as.numeric(gsub(",", "", tdata$sd.c))
if (!is.null(tdata$O.E))
tdata$O.E <- as.numeric(gsub(",", "", tdata$O.E))
if (!is.null(tdata$V))
tdata$V <- as.numeric(gsub(",", "", tdata$V))
tdata$TE <- as.numeric(gsub(",", "", tdata$TE))
## No warning concerning infinite values for
## seTE, lower and upper CI bound
tdata$seTE <- suppressWarnings(as.numeric(gsub(",", "", tdata$seTE)))
tdata$lower <- suppressWarnings(as.numeric(gsub(",", "", tdata$lower)))
tdata$upper <- suppressWarnings(as.numeric(gsub(",", "", tdata$upper)))
##
tdata$weight <- as.numeric(gsub(",", "", tdata$weight))
tdata$Q <- as.numeric(gsub(",", "", tdata$Q))
tdata$tau2 <- as.numeric(gsub(",", "", tdata$tau2))
tdata$Qint <- as.numeric(gsub(",", "", tdata$Qint))
##
diffcomp <- c(1, diff(tdata$comp.no))
diffoutc <- c(1, diff(tdata$outcome.no))
diffgrp <- c(1, diff(tdata$group.no))
##
sel.comp <- diffcomp != 0
sel.outc <- diffoutc != 0 & !sel.comp
sel.grp <- tdata$type != "" & diffgrp != 0 & !sel.comp & !sel.outc
sel.study <- !sel.comp & !sel.outc & !sel.grp
##
res <- list(title = title,
comparison =
data.frame(comp.no = selvar(tdata$comp.no, sel.comp),
complab = selvar(tdata$author, sel.comp)
),
outcome =
data.frame(comp.no = selvar(tdata$comp.no, sel.outc),
outcome.no = selvar(tdata$outcome.no, sel.outc),
##
type = selvar(tdata$type, sel.outc),
method = selvar(tdata$method, sel.outc),
sm = selvar(tdata$sm, sel.outc),
model = selvar(tdata$model, sel.outc),
common = selvar(tdata$common, sel.outc),
random = selvar(tdata$random, sel.outc),
outclab = selvar(tdata$author, sel.outc),
##
k = selvar(tdata$df, sel.outc) + 1,
##
event.e.pooled = selvar(tdata$event.e, sel.outc),
n.e.pooled = selvar(tdata$n.e, sel.outc),
event.c.pooled = selvar(tdata$event.c, sel.outc),
n.c.pooled = selvar(tdata$n.c, sel.outc),
##
TE.pooled = selvar(tdata$TE, sel.outc),
lower.pooled = selvar(tdata$lower, sel.outc),
upper.pooled = selvar(tdata$upper, sel.outc),
##
weight.pooled = selvar(tdata$weight, sel.outc),
##
Z.pooled = selvar(tdata$Z, sel.outc),
pval.TE.pooled = selvar(tdata$pval.TE, sel.outc),
##
Q = selvar(tdata$Q, sel.outc),
pval.Q = selvar(tdata$pval.Q, sel.outc),
I2 = selvar(tdata$I2, sel.outc),
tau2 = selvar(tdata$tau2, sel.outc),
##
Q.w = selvar(tdata$Qint, sel.outc),
pval.Q.w = selvar(tdata$pval.Qint, sel.outc),
I2.w = selvar(tdata$I2.Qint, sel.outc),
##
swap.events = selvar(tdata$swap.events, sel.outc),
enter.n = selvar(tdata$enter.n, sel.outc),
logscale = selvar(tdata$logscale, sel.outc),
##
label.e = selvar(tdata$label.e, sel.outc),
label.c = selvar(tdata$label.c, sel.outc),
label.left = selvar(tdata$label.left, sel.outc),
label.right = selvar(tdata$label.right, sel.outc)
),
group =
if (sum(sel.grp) > 0 ) {
data.frame(comp.no = selvar(tdata$comp.no, sel.grp),
outcome.no = selvar(tdata$outcome.no, sel.grp),
group.no = selvar(tdata$group.no, sel.grp),
grplab = selvar(tdata$author, sel.grp)
)}
else {
NA
},
study =
data.frame(comp.no = selvar(tdata$comp.no, sel.study),
outcome.no = selvar(tdata$outcome.no, sel.study),
group.no = selvar(tdata$group.no, sel.study),
studlab = selvar(tdata$author, sel.study),
year = selvar(tdata$year, sel.study),
##
event.e = selvar(tdata$event.e, sel.study),
n.e = selvar(tdata$n.e, sel.study),
event.c = selvar(tdata$event.c, sel.study),
n.c = selvar(tdata$n.c, sel.study),
##
mean.e = selvar(tdata$mean.e, sel.study),
sd.e = selvar(tdata$sd.e, sel.study),
mean.c = selvar(tdata$mean.c, sel.study),
sd.c = selvar(tdata$sd.c, sel.study),
##
O.E = selvar(tdata$O.E, sel.study),
V = selvar(tdata$V, sel.study),
##
TE = selvar(tdata$TE, sel.study),
seTE = selvar(tdata$seTE, sel.study),
##
lower.TE = selvar(tdata$lower, sel.study),
upper.TE = selvar(tdata$upper, sel.study),
weight = selvar(tdata$weight, sel.study),
##
order = selvar(tdata$order, sel.study)
)
)
##
if (is.data.frame(res$group))
res2 <- merge(res$study, res$group,
by = c("comp.no", "outcome.no", "group.no"),
all.x = TRUE)
else
res2 <- res$study
res2 <- merge(res2, res$outcome,
by = c("comp.no", "outcome.no"))
res2 <- merge(res2, res$comparison,
by = c("comp.no"))
##
sel.nocont <- (res2$mean.e == 0 & res2$sd.e == 0 &
res2$mean.c == 0 & res2$sd.c == 0)
res2$mean.e[sel.nocont] <- NA
res2$sd.e[sel.nocont] <- NA
res2$mean.c[sel.nocont] <- NA
res2$sd.c[sel.nocont] <- NA
##
if (is.factor(res2$O.E))
res2$O.E <- numchar(res2$O.E)
if (is.factor(res2$V))
res2$V <- numchar(res2$V)
sel.noOE <- res2$O.E == 0 & res2$V == 0
res2$O.E[sel.noOE] <- NA
res2$V[sel.noOE] <- NA
##
res2$complab <- as.character(res2$complab)
res2$outclab <- nachar(as.character(res2$outclab))
res2$studlab <- nachar(as.character(res2$studlab))
if (is.data.frame(res$group)) {
res2$grplab <- nachar(as.character(res2$grplab))
## Replace some XML code:
res2$grplab <- gsub("\\<", "<", res2$grplab)
res2$grplab <- gsub("\\>", ">", res2$grplab)
}
##
res2$sm <- as.character(res2$sm)
res2$method <- as.character(res2$method)
res2$type <- substring(res2$type, 1, 1)
res2$model <- as.character(res2$model)
##
res2$label.e <- nachar(as.character(res2$label.e))
res2$label.c <- nachar(as.character(res2$label.c))
res2$label.left <- nachar(as.character(res2$label.left))
res2$label.right <- nachar(as.character(res2$label.right))
##
if (numbers.in.labels & length(res2$comp.no) > 0) {
res2$complab <- paste0(res2$comp.no, " ", res2$complab)
res2$outclab <- paste0(res2$comp.no, ".", res2$outcome.no, " ",
res2$outclab)
if (is.data.frame(res$group))
res2$grplab <- paste0(res2$comp.no, ".", res2$outcome.no, ".",
res2$group.no, " ", res2$grplab)
}
##
res2 <- res2[order(res2$comp.no,
res2$outcome.no,
res2$group.no),]
##
attr(res2, "title") <- res$title
##
if (length(res2$comp.no) > 0) {
for (i in unique(res2$comp.no)) {
for (j in unique(res2$outcome.no[res2$comp.no == i])) {
sel2 <- res2$comp.no == i & res2$outcome.no == j
if (unique(res2$sm[sel2]) == "OTHER")
warning("Summary measure unclear for outcome '",
##paste0(unique(res2$comp.no[sel2]), ".",
## unique(res2$outcome.no[sel2])),
unique(res2$outclab[sel2]),
"'. Please use argument 'sm' in function metacr ",
"to choose adequate summary measure.")
}
}
}
##res2$TE[res2$sm == "HR"] <- log(res2$TE[res2$sm == "HR"])
##res2$sm[res2$sm == "log HR"] <- "HR"
iswap.events <- charmatch(tolower(as.character(res2$swap.events)),
c("yes", "no"), nomatch = NA)
res2$swap.events <- ifelse(iswap.events == 1, TRUE,
ifelse(iswap.events == 2, FALSE, NA))
##
ienter.n <- charmatch(tolower(as.character(res2$enter.n)),
c("yes", "no"), nomatch = NA)
res2$enter.n <- ifelse(ienter.n == 1, TRUE,
ifelse(ienter.n == 2, FALSE, NA))
##
ilogscale <- charmatch(tolower(as.character(res2$logscale)),
c("no", "yes"), nomatch = NA)
res2$logscale <- ifelse(ilogscale == 1, TRUE,
ifelse(ilogscale == 2, FALSE, NA))
attr(res2, "version") <- packageDescription("meta")$Version
class(res2) <- c("rm5", "data.frame")
res2
}
read.rm5.rm5 <- function(file, title, numbers.in.labels = TRUE, debug = 0) {
##
## Read data file
##
rdata <- readLines(file, warn = FALSE)
##
## Convert extended ASCII codes
##
rdata <- oct2txt(rdata)
##
## Extract title
##
if (missing(title)) {
sel1 <- grep("<TITLE", rdata)
sel2 <- grep("</TITLE", rdata)
title.orig <- rdata[unique(c(sel1[1], sel2[1]))]
title <- xml_text(as_xml_document(paste(title.orig, collapse = " ")))
}
if (debug) {
cat("\n***** TITLE *****\n")
cat(paste0("Title: ", title, "\n"))
##
if (debug == 3)
print(title.orig)
}
##
## Determine whether study data are available
##
sel.data1 <- grepl("<ANALYSES_AND_DATA", rdata)
sel.data2 <- grepl("</ANALYSES_AND_DATA", rdata)
##
if (!any(sel.data2)) {
warning("Cochrane review does not contain any study data.",
call. = FALSE)
return(NULL)
}
##
sel.data1 <- grep("<ANALYSES_AND_DATA", rdata)
sel.data2 <- grep("</ANALYSES_AND_DATA", rdata)
##
## Extract data (as vector of character strings)
##
txt <- rdata[(sel.data1 + 1):(sel.data2 - 1)]
##
sel.data1 <- grepl("<DICH_DATA", txt)
sel.data2 <- grepl("<CONT_DATA", txt)
sel.data3 <- grepl("<IV_DATA", txt)
sel.data4 <- grepl("<IPD_DATA", txt)
##
if (!any(sel.data1 | sel.data2 | sel.data3 | sel.data4)) {
warning("Cochrane review does not contain any usable study data.",
call. = FALSE)
return(NULL)
}
res <- data.frame(comp.no = NA, outcome.no = NA, group.no = NA,
id = "",
event.e = NA, n.e = NA, event.c = NA, n.c = NA,
mean.e = NA, sd.e = NA, mean.c = NA, sd.c = NA,
O.E = NA, V = NA,
TE = NA, seTE = NA, lower.TE = NA, upper.TE = NA,
weight = NA, order = NA, level = NA,
grplab = "",
overall = NA,
test.subgroup = NA,
type = "", method = "", sm = "", model = "",
common = NA, random = NA,
outclab = "",
k = NA,
event.e.pooled = NA, n.e.pooled = NA,
event.c.pooled = NA, n.c.pooled = NA,
TE.pooled = NA, lower.pooled = NA, upper.pooled = NA,
level.ma = NA,
weight.pooled = NA,
Z.pooled = NA, pval.TE.pooled = NA,
Q = NA, pval.Q = NA,
I2 = NA, tau2 = NA,
Q.w = NA, pval.Q.w = NA, I2.w = NA,
swap.events = NA, logscale = NA,
label.e = "", label.c = "",
label.left = "", label.right = "",
complab = "")
##
##
## Comparisons
##
##
sel.comp1 <- grep("<COMPARISON", txt)
sel.comp2 <- grep("</COMPARISON", txt)
##
if (length(sel.comp1) != length(sel.comp2))
stop("Malformed XML file (tag: COMPARISON)")
##
for (i in seq(along = sel.comp1)) {
txt.i <- txt[sel.comp1[i]:sel.comp2[i]]
sel.data.i <- c(grep("</NAME>", txt.i))
if (length(sel.data.i) > 0)
sel.i <- c(1:(max(c(2, min(sel.data.i)))), length(txt.i))
else
sel.i <- c(1:2, length(txt.i))
##
xml.i <- as_xml_document(paste(txt.i[sel.i], collapse = " "))
##
comp.no <- as.numeric(xml_attr(xml.i, "NO"))
complab <- xml_text(xml_find_all(xml.i, "//NAME"))
##
if (debug) {
cat("\n**** COMPARISON ****\n")
cat(paste0("Comp.no: ", comp.no, "\n"))
cat(paste0("complab: ", complab, "\n"))
##
if (debug == 3)
print(txt.i[sel.i])
}
##
## Binary outcomes
##
res <- extract_outcomes(txt.i, "DICH", res,
comp.no, complab,
debug = debug)
##
## Continuous outcomes
##
res <- extract_outcomes(txt.i, "CONT", res,
comp.no, complab,
debug = debug)
##
## IV outcomes
##
res <- extract_outcomes(txt.i, "IV", res,
comp.no, complab,
debug = debug)
##
## IPD outcomes
##
res <- extract_outcomes(txt.i, "IPD", res,
comp.no, complab,
debug = debug)
}
##
res <- res[-1, ]
##
## Determine whether information on included studies are available
##
sel.incl1 <- grepl("<INCLUDED_STUDIES ", rdata) |
grepl("<INCLUDED_STUDIES>", rdata)
sel.incl2 <- grepl("</INCLUDED_STUDIES>", rdata)
##
if (any(sel.incl2)) {
##
## Extract study information (as vector of character strings)
##
sel.incl1 <- c(grep("<INCLUDED_STUDIES ", rdata),
grep("<INCLUDED_STUDIES>", rdata))
sel.incl2 <- grep("</INCLUDED_STUDIES>", rdata)
##
study <- rdata[(sel.incl1 + 1):(sel.incl2 - 1)]
##
sel.study1 <- grep("<STUDY", study)
sel.study2 <- grep("</STUDY", study)
##
id <- studlab <- year <- rep("", length(sel.study1))
##
if ((length(sel.study1) > 0 | length(sel.study2) > 0) &&
(length(sel.study1) == length(sel.study2))) {
if (debug)
cat(paste0("\n* STUDY *\n"))
for (s in seq(along = sel.study1)) {
study.s <- study[sel.study1[s]:sel.study2[s]]
xml.s <- as_xml_document(paste(study.s, collapse = " "))
##
id[s] <- xml_attr(xml.s, "ID")
studlab[s] <- xml_attr(xml.s, "NAME")
year[s] <- xml_attr(xml.s, "YEAR")
##
if (debug >= 2) {
cat("- id:\n")
print(id)
cat("- studlab:\n")
print(studlab)
cat("- year:\n")
print(year)
##
if (debug == 3)
print(study.s)
}
}
##
names.res <- names(res)
res.study <- data.frame(id, studlab, year)
res <- merge(res, res.study, by = "id",
all.x = TRUE)
##
names.res <- c(names.res[1:4], "studlab", "year",
names.res[5:length(names.res)])
##
res <- res[, names.res]
}
}
res <- res[order(res$comp.no, res$outcome.no, res$group.no), ]
##
if (numbers.in.labels & length(res$comp.no) > 0) {
res$complab <- paste0(res$comp.no, " ", res$complab)
res$outclab <- paste0(res$comp.no, ".", res$outcome.no, " ",
res$outclab)
sel.grp <- !is.na(res$group.no)
if (any(sel.grp))
res$grplab[sel.grp] <-
paste0(res$comp.no, ".", res$outcome.no, ".",
res$group.no, " ", res$grplab)[sel.grp]
}
##
res$test.subgroup[is.na(res$group.no)] <- NA
##
row.names(res) <- 1:nrow(res)
##
res$id <- as.character(res$id)
res$studlab <- as.character(res$studlab)
res$year <- as.character(res$year)
res$grplab <- as.character(res$grplab)
res$type <- as.character(res$type)
res$method <- as.character(res$method)
res$sm <- as.character(res$sm)
res$model <- as.character(res$model)
res$label.e <- as.character(res$label.e)
res$label.c <- as.character(res$label.c)
res$label.left <- as.character(res$label.left)
res$label.right <- as.character(res$label.right)
##
## sel.rel <- is_relative_effect(res$sm)
## res$TE[sel.rel] <- log(res$TE[sel.rel])
## res$lower.TE[sel.rel] <- log(res$lower.TE[sel.rel])
## res$upper.TE[sel.rel] <- log(res$upper.TE[sel.rel])
## res$seTE <- TE.seTE.ci(res$lower.TE, res$upper.TE, res$level)$seTE
##
res$fixed <- res$common
##
attr(res, "title") <- title
attr(res, "version") <- packageDescription("meta")$Version
class(res) <- c("rm5", "data.frame")
res
}
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.