Skip to content

Commit 378924c

Browse files
RostuRostu
authored
Merge pull request #5 from leibniz-psychology/development
Development
2 parents e1e8d19 + f80234f commit 378924c

14 files changed

Lines changed: 744 additions & 657 deletions

‎NAMESPACE‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ importFrom("utils", "str")
55

66
export(cumulforest)
77
export(forest)
8-
export(funnelPLot)
8+
export(funnelPlot)
99
export(jsonSummary)
1010
export(metapower)
1111
export(netMetaForestplot)
@@ -25,3 +25,7 @@ export(rma)
2525
export(checkIntegrity)
2626
export(checkData)
2727
export(checkParameter)
28+
export(createData)
29+
export(testListParameter)
30+
export(testpredParameter)
31+
export(createJsonFromData)

‎R/createData.R‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
# Load required package
2+
library(jsonlite)
3+
4+
# Define the function
5+
createData <- function(json_string) {
6+
# Trim any extra whitespace
7+
json_string <- trimws(json_string)
8+
9+
# Parse the JSON string into an R list
10+
parsed_data <- jsonlite::fromJSON(json_string)
11+
12+
# Convert the list to a data frame
13+
dataset <- as.data.frame(parsed_data)
14+
15+
# Return the data frame
16+
return(dataset)
17+
}

‎R/createJsonFromData.R‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
# Load required package
2+
library(jsonlite)
3+
4+
# Define the function
5+
createJsonFromData <- function(d) {
6+
dat <- checkData(d)
7+
8+
json_data <- toJSON(dat, pretty = TRUE, digits = NA)
9+
10+
write(json_data, paste0(d, ".json"))
11+
12+
}

‎R/funnelPlot.R‎

Lines changed: 60 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -1,60 +1,60 @@
1-
#' @title Funnel plot
2-
#' @description
3-
#' Using metafor package to create a funnel plot.
4-
#' @param yi
5-
#' A \code{string} of the variable which holds the vector of length k with the observed effect sizes or outcomes in the selected dataset (d)
6-
#' @param vi
7-
#' A \code{string} of the variable which holds the vector of length k with the corresponding sampling variances in the selected dataset (d)
8-
#' @param d
9-
#' A \code{string} representing the dataset name that should be used for fitting.
10-
#' @param effectName
11-
#' A \code{string} representing the effect name that should be printed as label. defaults to "Effect"
12-
#' @param measure
13-
#' A character string indicating underlying summary measure.
14-
#' @return
15-
#' returns a Funnel plot for the given dataset
16-
#' @author Robert Studtrucker
17-
#' @export
18-
funnelPLot <- function(yi,vi,measure,d,peer="no", effectName="Effect") {
19-
20-
requireNamespace("metafor")
21-
22-
#load the in variable d defined dataset from the package
23-
dat <- checkData(d)
24-
checkParameter(dat,c(yi,vi,"r_peer"))
25-
26-
# Filtern nach veröffentlichten Studien wenn in der Anwendung ausgewählt (peer reviewed yes/no)
27-
# Per default werden alle Studien mit einbezogen
28-
if(peer == "yes"){
29-
filtered_dat <- subset(dat,r_peer=="yes")
30-
}else{
31-
filtered_dat<-dat
32-
}
33-
34-
if(measure == "COR") {
35-
# z-standardisierte Daten erstellen
36-
temp_dat <- metafor::escalc(measure="ZCOR", ri=filtered_dat[,yi], vi=filtered_dat[,vi], ni=filtered_dat[,"o_ni"], data=filtered_dat, var.names=c("o_zcor","o_zcor_var"))
37-
38-
# Modell berechnen
39-
rma_model <- metafor::rma.uni(temp_dat[,"o_zcor"],temp_dat[,"o_zcor_var"], measure="ZCOR")
40-
41-
RTest <-metafor::regtest(x=rma_model)
42-
metafor::funnel(rma_model, yaxis="sei") # 'label'
43-
metafor::funnel(rma_model, level=c(90, 95, 99), shade=c("white", "orange", "red"), refline=0, legend=TRUE)
44-
gc() # Force R to release memory it is no longer using
45-
46-
return(RTest)
47-
48-
}else{
49-
rma_model <- metafor::rma.uni(yi=filtered_dat[,yi],vi=filtered_dat[,vi],measure=measure)
50-
RTest <-metafor::regtest(x=rma_model)
51-
52-
metafor::funnel(rma_model, yaxis="sei") # 'label'
53-
metafor::funnel(rma_model, level=c(90, 95, 99), shade=c("white", "orange", "red"), refline=0, legend=TRUE)
54-
gc() # Force R to release memory it is no longer using
55-
56-
return(RTest)
57-
}
58-
59-
60-
}
1+
#' @title Funnel plot
2+
#' @description
3+
#' Using metafor package to create a funnel plot.
4+
#' @param yi
5+
#' A \code{string} of the variable which holds the vector of length k with the observed effect sizes or outcomes in the selected dataset (d)
6+
#' @param vi
7+
#' A \code{string} of the variable which holds the vector of length k with the corresponding sampling variances in the selected dataset (d)
8+
#' @param d
9+
#' A \code{string} representing the dataset name that should be used for fitting.
10+
#' @param effectName
11+
#' A \code{string} representing the effect name that should be printed as label. defaults to "Effect"
12+
#' @param measure
13+
#' A character string indicating underlying summary measure.
14+
#' @return
15+
#' returns a Funnel plot for the given dataset
16+
#' @author Robert Studtrucker
17+
#' @export
18+
funnelPlot <- function(yi,vi,measure,d,peer="no", effectName="Effect") {
19+
20+
requireNamespace("metafor")
21+
22+
#load the in variable d defined dataset from the package
23+
dat <- d
24+
checkParameter(dat,c(yi,vi,"r_peer"))
25+
26+
# Filtern nach veröffentlichten Studien wenn in der Anwendung ausgewählt (peer reviewed yes/no)
27+
# Per default werden alle Studien mit einbezogen
28+
if(peer == "yes"){
29+
filtered_dat <- subset(dat,r_peer=="yes")
30+
}else{
31+
filtered_dat<-dat
32+
}
33+
34+
if(measure == "COR") {
35+
# z-standardisierte Daten erstellen
36+
temp_dat <- metafor::escalc(measure="ZCOR", ri=filtered_dat[,yi], vi=filtered_dat[,vi], ni=filtered_dat[,"o_ni"], data=filtered_dat, var.names=c("o_zcor","o_zcor_var"))
37+
38+
# Modell berechnen
39+
rma_model <- metafor::rma.uni(temp_dat[,"o_zcor"],temp_dat[,"o_zcor_var"], measure="ZCOR")
40+
41+
RTest <-metafor::regtest(x=rma_model)
42+
metafor::funnel(rma_model, yaxis="sei") # 'label'
43+
metafor::funnel(rma_model, level=c(90, 95, 99), shade=c("white", "orange", "red"), refline=0, legend=TRUE)
44+
gc() # Force R to release memory it is no longer using
45+
46+
return(RTest)
47+
48+
}else{
49+
rma_model <- metafor::rma.uni(yi=filtered_dat[,yi],vi=filtered_dat[,vi],measure=measure)
50+
RTest <-metafor::regtest(x=rma_model)
51+
52+
metafor::funnel(rma_model, yaxis="sei") # 'label'
53+
metafor::funnel(rma_model, level=c(90, 95, 99), shade=c("white", "orange", "red"), refline=0, legend=TRUE)
54+
gc() # Force R to release memory it is no longer using
55+
56+
return(RTest)
57+
}
58+
59+
60+
}

‎R/netMetaGetTRTS.R‎

Lines changed: 23 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,23 @@
1-
#' @title Helper Function to get possible reference categories fot the netmeta model
2-
#' @description
3-
#' Helper Function to get possible reference categories to be used in the netmeta model
4-
#' This function is used to populate the gui with reference options
5-
#' @param d
6-
#' A \code{string} representing the dataset name for which the reference categories should be retrieved
7-
#' @return create a json file containing the reference categories in the opencpu session which can then be retrieved in another call
8-
#' @author Robert Studtrucker
9-
#' @export
10-
netMetagetTRTS <- function(d) {
11-
#Todo check if there is a better way to do this
12-
requireNamespace("jsonlite")
13-
14-
#load the in variable d defined dataset from the package
15-
dat <- checkData(d)
16-
17-
combined_treat<-c()
18-
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
19-
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
20-
21-
trts<-unique(combined_treat)[!is.na(unique(combined_treat))]
22-
jsonlite::write_json(trts, "trts.json")
23-
}
1+
#' @title Helper Function to get possible reference categories fot the netmeta model
2+
#' @description
3+
#' Helper Function to get possible reference categories to be used in the netmeta model
4+
#' This function is used to populate the gui with reference options
5+
#' @param d
6+
#' A \code{string} representing the dataset name for which the reference categories should be retrieved
7+
#' @return create a json file containing the reference categories in the opencpu session which can then be retrieved in another call
8+
#' @author Robert Studtrucker
9+
#' @export
10+
netMetagetTRTS <- function(d) {
11+
#Todo check if there is a better way to do this
12+
requireNamespace("jsonlite")
13+
14+
#load the in variable d defined dataset from the package
15+
dat <- d
16+
17+
combined_treat<-c()
18+
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
19+
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
20+
21+
trts<-unique(combined_treat)[!is.na(unique(combined_treat))]
22+
jsonlite::write_json(trts, "trts.json")
23+
}

‎R/netMetaModel.R‎

Lines changed: 43 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -1,43 +1,43 @@
1-
2-
#' @title netmeta model
3-
#' @description
4-
#' Creates a netmeta model which is used for further function calls
5-
#' @param d
6-
#' A \code{string} representing the dataset name that is used to fit the netmeta model.
7-
#' @param reference
8-
#' A \code{string} representing the reference category that should be used for the netmeta model.
9-
#' @return returns nothing but creates a netmeta model which could be uses in other function calls
10-
#' @author Robert Studtrucker
11-
#' @export
12-
netMetaModel <- function(d,reference="Placebo") {
13-
14-
#load needed dependencies
15-
requireNamespace("netmeta")
16-
17-
18-
#load the in variable d defined dataset from the package
19-
dat <- checkData(d)
20-
21-
TE <- dat[,"TE"]
22-
seTE <- dat[,"seTE"]
23-
studlab<-dat[,"studlab"]
24-
treat1<-dat[,"treat1"]
25-
treat2<-dat[,"treat2"]
26-
27-
combined_treat<-c()
28-
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
29-
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
30-
31-
nma1<-netmeta::netmeta(
32-
data=dat,
33-
TE=TE,
34-
seTE = seTE,
35-
studlab = studlab,
36-
treat1 = treat1,
37-
treat2 = treat2,
38-
comb.fixed = FALSE,
39-
seq = unique(combined_treat)[!is.na(unique(combined_treat))],
40-
tol.multiarm=0.1,
41-
ref = reference,
42-
warn = FALSE)
43-
}
1+
2+
#' @title netmeta model
3+
#' @description
4+
#' Creates a netmeta model which is used for further function calls
5+
#' @param d
6+
#' A \code{string} representing the dataset name that is used to fit the netmeta model.
7+
#' @param reference
8+
#' A \code{string} representing the reference category that should be used for the netmeta model.
9+
#' @return returns nothing but creates a netmeta model which could be uses in other function calls
10+
#' @author Robert Studtrucker
11+
#' @export
12+
netMetaModel <- function(d,reference="Placebo") {
13+
14+
#load needed dependencies
15+
requireNamespace("netmeta")
16+
17+
18+
#load the in variable d defined dataset from the package
19+
dat <- d
20+
21+
TE <- dat[,"TE"]
22+
seTE <- dat[,"seTE"]
23+
studlab<-dat[,"studlab"]
24+
treat1<-dat[,"treat1"]
25+
treat2<-dat[,"treat2"]
26+
27+
combined_treat<-c()
28+
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
29+
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
30+
31+
nma1<-netmeta::netmeta(
32+
data=dat,
33+
TE=TE,
34+
seTE = seTE,
35+
studlab = studlab,
36+
treat1 = treat1,
37+
treat2 = treat2,
38+
comb.fixed = FALSE,
39+
seq = unique(combined_treat)[!is.na(unique(combined_treat))],
40+
tol.multiarm=0.1,
41+
ref = reference,
42+
warn = FALSE)
43+
}

‎R/netMetaNetgraph.R‎

Lines changed: 37 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -1,37 +1,37 @@
1-
#' @title plot network graph
2-
#' @description
3-
#' Using the R package netmeta to to create and and return a network graph.
4-
#' This indirect calling is needed since calling functions other than those from psychOpenCama package is blocked on the opencpu server for security reasons.
5-
#' @param model
6-
#' A netmeta model object
7-
#' @param d
8-
#' A \code{string} representing the dataset name that is used to extract the sequence and treatment parameter to be used of the netmeta::netgraph function
9-
#' @return returns a network graph for a given netmeta model.
10-
#' @author Robert Studtrucker
11-
#' @export
12-
netMetaNetgraph <- function(model,d) {
13-
14-
#load needed dependencies
15-
requireNamespace("netmeta")
16-
17-
18-
#load the in variable d defined dataset from the package
19-
dat <- checkData(d)
20-
21-
#TE <- dat[,"TE"]
22-
#seTE <- dat[,"seTE"]
23-
#studlab<-dat[,"studlab"]
24-
#treat1<-dat[,"treat1"]
25-
#treat2<-dat[,"treat2"]
26-
27-
combined_treat<-c()
28-
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
29-
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
30-
31-
trts<-unique(combined_treat)[!is.na(unique(combined_treat))]
32-
33-
gr<-netmeta::netgraph(model, col="#0000CC", col.points="white", seq = trts)
34-
print(gr)
35-
# gc() # Force R to release memory it is no longer using
36-
37-
}
1+
#' @title plot network graph
2+
#' @description
3+
#' Using the R package netmeta to to create and and return a network graph.
4+
#' This indirect calling is needed since calling functions other than those from psychOpenCama package is blocked on the opencpu server for security reasons.
5+
#' @param model
6+
#' A netmeta model object
7+
#' @param d
8+
#' A \code{string} representing the dataset name that is used to extract the sequence and treatment parameter to be used of the netmeta::netgraph function
9+
#' @return returns a network graph for a given netmeta model.
10+
#' @author Robert Studtrucker
11+
#' @export
12+
netMetaNetgraph <- function(model,d) {
13+
14+
#load needed dependencies
15+
requireNamespace("netmeta")
16+
17+
18+
#load the in variable d defined dataset from the package
19+
dat <- d
20+
21+
#TE <- dat[,"TE"]
22+
#seTE <- dat[,"seTE"]
23+
#studlab<-dat[,"studlab"]
24+
#treat1<-dat[,"treat1"]
25+
#treat2<-dat[,"treat2"]
26+
27+
combined_treat<-c()
28+
combined_treat<-c(combined_treat,dat["treat1"],recursive = TRUE,use.names=FALSE)
29+
combined_treat<-c(combined_treat,dat["treat2"],recursive = TRUE,use.names=FALSE)
30+
31+
trts<-unique(combined_treat)[!is.na(unique(combined_treat))]
32+
33+
gr<-netmeta::netgraph(model, col="#0000CC", col.points="white", seq = trts)
34+
print(gr)
35+
# gc() # Force R to release memory it is no longer using
36+
37+
}

0 commit comments

Comments
 (0)