Skip to content

Commit dfc4a68

Browse files
Merge pull request datashield#329 from datashield/v6.3.0-dev
V6.3.0 dev
2 parents 2f40d47 + a14641e commit dfc4a68

333 files changed

Lines changed: 97410 additions & 1154 deletions

File tree

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

.Rbuildignore

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,5 +4,6 @@
44
^azure-pipelines_check\.Rout$
55
^LICENSE.md$
66
^_pkgdown\.yml$
7+
^data$
78
^docs$
89
^pkgdown$

.gitignore

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,3 +5,4 @@
55
*.Rproj
66
.Rproj.user
77
.DS_Store
8+
.Rapp.history

DESCRIPTION

Lines changed: 15 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,32 @@
11
Package: dsBase
22
Title: DataSHIELD server site base functions
33
Description: DataSHIELD server site base functions.
4-
Version: 6.2.0
4+
Version: 6.3.0
55
Author: DataSHIELD Developers <datashield@newcastle.ac.uk>
66
Maintainer: DataSHIELD Developers <datashield@newcastle.ac.uk>
77
License: GPL-3
88
Depends:
99
R (>= 3.5.0)
1010
Imports:
1111
RANN,
12-
nlme,
1312
stringr,
1413
lme4,
1514
dplyr,
1615
reshape2,
1716
polycor (>= 0.8),
18-
splines
17+
splines,
18+
gamlss,
19+
gamlss.dist,
20+
mice,
21+
childsds
1922
AggregateMethods:
2023
asFactorDS1,
2124
asListDS,
25+
aucDS,
2226
boxPlotGGDS,
2327
checkNegValueDS,
2428
classDS,
29+
colnamesDS,
2530
corTestDS,
2631
corDS,
2732
covDS,
@@ -30,6 +35,7 @@ AggregateMethods:
3035
extractQuantilesDS1,
3136
extractQuantilesDS2,
3237
dimDS,
38+
gamlssDS,
3339
glmDS1,
3440
glmDS2,
3541
glmerSLMADS2,
@@ -41,7 +47,6 @@ AggregateMethods:
4147
hetcorDS,
4248
histogramDS1,
4349
histogramDS2,
44-
lsDS,
4550
isNaDS,
4651
isValidDS,
4752
kurtosisDS1,
@@ -51,11 +56,13 @@ AggregateMethods:
5156
lexisDS1,
5257
listDisclosureSettingsDS,
5358
lmerSLMADS2,
59+
lsDS,
5460
matrixDetDS1,
5561
meanDS,
5662
meanSdGpDS,
5763
messageDS,
5864
metadataDS,
65+
miceDS,
5966
minMaxRandDS,
6067
namesDS,
6168
numNaDS,
@@ -76,7 +83,6 @@ AggregateMethods:
7683
tapplyDS,
7784
testObjExistsDS,
7885
varDS,
79-
colnamesDS,
8086
exists=base::exists,
8187
is.character=base::is.character,
8288
is.factor=base::is.factor,
@@ -101,6 +107,7 @@ AssignMethods:
101107
BooleDS,
102108
boxPlotGG_data_TreatmentDS,
103109
boxPlotGG_data_Treatment_numericDS,
110+
bp_standardsDS,
104111
cbindDS,
105112
cDS,
106113
changeRefGroupDS,
@@ -116,6 +123,7 @@ AssignMethods:
116123
glmSLMADS.assign,
117124
glmSummaryDS.as,
118125
getWGSRDS,
126+
igb_standardsDS,
119127
listDS,
120128
lexisDS2,
121129
lexisDS3,
@@ -146,7 +154,6 @@ AssignMethods:
146154
rPoisDS,
147155
rUnifDS,
148156
sampleDS,
149-
seedDS,
150157
seqDS,
151158
sqrtDS,
152159
subsetByClassDS,
@@ -177,7 +184,7 @@ AssignMethods:
177184
unlist=base::unlist
178185
Options:
179186
datashield.privacyLevel=5,
180-
default.datashield.privacyControlLevel="permissive",
187+
default.datashield.privacyControlLevel="banana",
181188
default.nfilter.glm=0.33,
182189
default.nfilter.kNN=3,
183190
default.nfilter.string=80,
@@ -187,5 +194,5 @@ Options:
187194
default.nfilter.noise=0.25,
188195
default.nfilter.levels.density=0.33,
189196
default.nfilter.levels.max=40
190-
RoxygenNote: 7.1.2
197+
RoxygenNote: 7.2.3
191198
Encoding: UTF-8

NAMESPACE

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,15 +12,18 @@ export(asListDS)
1212
export(asLogicalDS)
1313
export(asMatrixDS)
1414
export(asNumericDS)
15+
export(aucDS)
1516
export(blackBoxDS)
1617
export(blackBoxRanksDS)
1718
export(boxPlotGGDS)
1819
export(boxPlotGG_data_TreatmentDS)
1920
export(boxPlotGG_data_Treatment_numericDS)
21+
export(bp_standardsDS)
2022
export(cDS)
2123
export(cbindDS)
2224
export(changeRefGroupDS)
2325
export(checkNegValueDS)
26+
export(checkPermissivePrivacyControlLevel)
2427
export(classDS)
2528
export(colnamesDS)
2629
export(completeCasesDS)
@@ -38,6 +41,7 @@ export(dmtC2SDS)
3841
export(elsplineDS)
3942
export(extractQuantilesDS1)
4043
export(extractQuantilesDS2)
44+
export(gamlssDS)
4145
export(getWGSRDS)
4246
export(glmDS1)
4347
export(glmDS2)
@@ -54,6 +58,7 @@ export(heatmapPlotDS)
5458
export(hetcorDS)
5559
export(histogramDS1)
5660
export(histogramDS2)
61+
export(igb_standardsDS)
5762
export(isNaDS)
5863
export(isValidDS)
5964
export(kurtosisDS1)
@@ -82,6 +87,7 @@ export(meanSdGpDS)
8287
export(mergeDS)
8388
export(messageDS)
8489
export(metadataDS)
90+
export(miceDS)
8591
export(minMaxRandDS)
8692
export(namesDS)
8793
export(nsDS)
@@ -127,3 +133,10 @@ export(unListDS)
127133
export(uniqueDS)
128134
export(varDS)
129135
export(vectorDS)
136+
import(childsds)
137+
import(dplyr)
138+
import(gamlss)
139+
import(gamlss.dist)
140+
import(mice)
141+
importFrom(gamlss.dist,pST3)
142+
importFrom(gamlss.dist,qST3)

R/BooleDS.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,11 +26,11 @@
2626
BooleDS <- function(V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL, na.assign.text, numeric.output=TRUE){
2727

2828
# Check Permissive Privacy Control Level.
29-
checkPermissivePrivacyControlLevel()
29+
dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana'))
3030

3131
#########################################################################
3232
# DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS #
33-
thr <- listDisclosureSettingsDS() #
33+
thr <- dsBase::listDisclosureSettingsDS() #
3434
#nfilter.tab<-as.numeric(thr$nfilter.tab) #
3535
#nfilter.glm<-as.numeric(thr$nfilter.glm) #
3636
#nfilter.subset<-as.numeric(thr$nfilter.subset) #

R/aucDS.R

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
#'
2+
#' @title aucDS an aggregate function called by ds.auc
3+
#' @description This function calculates the C-statistic or AUC for logistic
4+
#' regression models.
5+
#' @details The AUC determines the discriminative ability of a model.
6+
#' @param pred the name of the vector of the predicted values
7+
#' @param y the name of the outcome variable. Note that this variable should include
8+
#' the complete cases that are used in the regression model.
9+
#' @return returns the AUC and its standard error
10+
#' @author Demetris Avraam for DataSHIELD Development Team
11+
#' @export
12+
#'
13+
aucDS <- function(pred=pred, y=y){
14+
15+
if(is.character(pred)){
16+
pred <- eval(parse(text = pred), envir = parent.frame())
17+
}
18+
if(is.character(y)){
19+
y <- eval(parse(text = y), envir = parent.frame())
20+
}
21+
22+
y <- as.numeric(as.character(y))
23+
24+
n <- length(pred)
25+
n1 <- sum(y)
26+
mean.rank <- mean(rank(pred)[y == 1])
27+
AUC <- (mean.rank - (n1 + 1)/2)/(n - n1)
28+
n0 <- n-n1
29+
q0 <- AUC*(1-AUC)
30+
q1 <- AUC/(2-AUC)-AUC^2
31+
q2 <- 2*AUC^2/(1+AUC)-AUC^2
32+
se <- sqrt((q0+(n0-1)*q1+(n1-1)*q2)/(n0*n1))
33+
34+
return(list(AUC=AUC,se=se))
35+
36+
}

R/blackBoxDS.R

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -54,16 +54,16 @@ blackBoxDS <- function(input.var.name=NULL,
5454
shared.seedval, synth.real.ratio, NA.manage){ #START FUNC
5555

5656
#######################################################
57-
#MODULE 1: CAPTURE THE nfilter SETTINGS
58-
#thr<-dsBase::listDisclosureSettingsDS()
59-
#nfilter.tab <- as.numeric(thr$nfilter.tab)
60-
#nfilter.glm <- as.numeric(thr$nfilter.glm)
61-
#nfilter.subset <- as.numeric(thr$nfilter.subset)
62-
#nfilter.string <- as.numeric(thr$nfilter.string)
57+
#MODULE 1: CAPTURE THE nfilter SETTINGS
58+
#thr<-dsBase::listDisclosureSettingsDS()
59+
#nfilter.tab <- as.numeric(thr$nfilter.tab)
60+
#nfilter.glm <- as.numeric(thr$nfilter.glm)
61+
#nfilter.subset <- as.numeric(thr$nfilter.subset)
62+
#nfilter.string <- as.numeric(thr$nfilter.string)
6363
#nfilter.stringShort <- as.numeric(thr$nfilter.stringShort)
64-
#nfilter.kNN <- as.numeric(thr$nfilter.kNN)
65-
#nfilter.noise <- as.numeric(thr$nfilter.noise)
66-
#nfilter.levels <- as.numeric(thr$nfilter.levels)
64+
#nfilter.kNN <- as.numeric(thr$nfilter.kNN)
65+
#nfilter.noise <- as.numeric(thr$nfilter.noise)
66+
#nfilter.levels <- as.numeric(thr$nfilter.levels)
6767
########################################################
6868

6969

R/boxPlotGGDS.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,7 @@ boxPlotGGDS <- function(data_table, group = NULL, group2 = NULL){
2727

2828
###################################################################
2929
# MODULE 1: CAPTURE THE subset filter SETTINGS #
30-
thr <- listDisclosureSettingsDS() #
30+
thr <- dsBase::listDisclosureSettingsDS() #
3131
nfilter.subset <- as.numeric(thr$nfilter.subset) #
3232
###################################################################
3333

@@ -52,7 +52,7 @@ boxPlotGGDS <- function(data_table, group = NULL, group2 = NULL){
5252
results <- list(data = stats_full, "double_group")
5353
}
5454
else{
55-
if(class(data_table) == "data.frame"){
55+
if("data.frame" %in% class(data_table)){
5656
stats_full <- stats::aggregate(.~x, data_table, function(x){stats::quantile(x,c(0.05,0.25,0.5,0.75,0.95))})
5757
stats_n <- stats::aggregate(.~x, data_table, function(x){length(x)})$value
5858
stats <- data.frame(stats_full$value)

R/boxPlotGG_data_TreatmentDS.R

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -26,15 +26,15 @@ boxPlotGG_data_TreatmentDS <- function(table, variables, group = NULL, group2 =
2626
data <- table[, c(variables)]
2727
}
2828
else{
29-
if(class(table[[group]]) != "factor"){
29+
if(! any(c("factor") %in% class(table[[group]]))) {
3030
stop("Grouping variable must be of class factor")
3131
}
3232
data <- table[, c(variables, group)]
3333
}
3434

3535
}
3636
else{
37-
if(class(table[[group]]) != "factor" | class(table[[group2]]) != "factor"){
37+
if((! any(c("factor") %in% class(table[[group]]))) | (! any(c("factor") %in% class(table[[group2]])))){
3838
stop("Grouping variable must be of class factor")
3939
}
4040
data <- table[, c(variables, group, group2)]
@@ -70,4 +70,4 @@ boxPlotGG_data_TreatmentDS <- function(table, variables, group = NULL, group2 =
7070

7171
return(data)
7272

73-
}
73+
}

R/bp_standardsDS.R

Lines changed: 84 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,84 @@
1+
#'
2+
#' @title Calculates Blood pressure z-scores
3+
#' @description The function calculates blood pressure z-scores in two steps:
4+
#' Step 1. Calculates z-score of height according to CDC growth chart (Not the
5+
#' WHO growth chart!). Step 2. Calculates z-score of BP according to the fourth
6+
#' report on BP management, USA
7+
#' @param sex the name of the sex variable. The variable should be coded as 1 for males
8+
#' and 2 for females. If it is coded differently (e.g. 0/1), then you can use the
9+
#' ds.recodeValues function to recode the categories to 1/2 before the use of
10+
#' ds.bp_standards
11+
#' @param age the name of the age variable in years.
12+
#' @param height the name of the height variable in cm
13+
#' @param bp the name of the blood pressure variable.
14+
#' @param systolic logical. If TRUE (default) the function assumes conversion of
15+
#' systolic blood pressure. If FALSE the function assumes conversion of diastolic
16+
#' blood pressure.
17+
#' @return assigns a new object on the server-side. The assigned object is a list
18+
#' with two elements: the 'Zbp' which is the zscores of the blood pressure and 'perc'
19+
#' which is the percentiles of the BP zscores.
20+
#' @note The z-scores of height based on CDC growth charts are calculated
21+
#' by the sds function from the childsds R package.
22+
#' @author Demetris Avraam for DataSHIELD Development Team
23+
#' @import childsds
24+
#' @export
25+
#'
26+
bp_standardsDS <- function(sex=sex, age=age, height=height, bp=bp, systolic=systolic){
27+
28+
if(is.character(sex)){
29+
sex <- eval(parse(text = sex), envir = parent.frame())
30+
}
31+
if(is.character(age)){
32+
age <- eval(parse(text = age), envir = parent.frame())
33+
}
34+
if(is.character(height)){
35+
height <- eval(parse(text = height), envir = parent.frame())
36+
}
37+
if(is.character(bp)){
38+
bp <- eval(parse(text = bp), envir = parent.frame())
39+
}
40+
41+
# convert height to a Z-score relative to age and sex based on CDC growth charts
42+
Zht <- sds(value=height, age=age, sex=sex, male="1", female="2",
43+
ref = childsds::cdc.ref, item = "height2_20", type = "SDS")
44+
45+
# Compute the expected BP (systolic or diastolic) for males/females of age y years and height
46+
# h inches using the regression coefficients given in table B-1 in
47+
# https://www.nhlbi.nih.gov/sites/default/files/media/docs/hbp_ped.pdf
48+
males_idx <- which(sex==1)
49+
females_idx <- which(sex==2)
50+
mu <- rep(NA, times=length(sex))
51+
if(systolic==TRUE){
52+
mu[males_idx] <- 102.19768 + 1.82416 * (age[males_idx]-10) + 0.12776 * (age[males_idx]-10)^2 +
53+
0.00249 * (age[males_idx]-10)^3 - 0.00135 * (age[males_idx]-10)^4 + 2.73157 * Zht[males_idx] -
54+
0.19618 * Zht[males_idx]^2 - 0.04659 * Zht[males_idx]^3 + 0.00947 * Zht[males_idx]^4
55+
mu[females_idx] <- 102.01027 + 1.94397 * (age[females_idx]-10) + 0.00598 * (age[females_idx]-10)^2 -
56+
0.00789 * (age[females_idx]-10)^3 - 0.00059 * (age[females_idx]-10)^4 + 2.03526 * Zht[females_idx] +
57+
0.02534 * Zht[females_idx]^2 - 0.01884 * Zht[females_idx]^3 + 0.00121 * Zht[females_idx]^4
58+
}
59+
if(systolic==FALSE){
60+
mu[males_idx] <- 61.01217 + 0.68314 * (age[males_idx]-10) - 0.09835 * (age[males_idx]-10)^2 +
61+
0.01711 * (age[males_idx]-10)^3 + 0.00045 * (age[males_idx]-10)^4 + 1.46993 * Zht[males_idx] -
62+
0.07849 * Zht[males_idx]^2 - 0.03144 * Zht[males_idx]^3 + 0.00967 * Zht[males_idx]^4
63+
mu[females_idx] <- 60.50510 + 1.01301 * (age[females_idx]-10) + 0.01157 * (age[females_idx]-10)^2 +
64+
0.00424 * (age[females_idx]-10)^3 - 0.00137 * (age[females_idx]-10)^4 + 1.16641 * Zht[females_idx] +
65+
0.12795 * Zht[females_idx]^2 - 0.03869 * Zht[females_idx]^3 - 0.00079 * Zht[females_idx]^4
66+
}
67+
68+
# convert the observed BP to a Z-score (Zbp) using sigmas given in table B-1
69+
Zbp <- rep(NA, times=length(mu))
70+
if(systolic==TRUE){
71+
Zbp[males_idx] <- (bp[males_idx]-mu[males_idx])/10.7128
72+
Zbp[females_idx] <- (bp[females_idx]-mu[females_idx])/10.4855
73+
}
74+
if(systolic==FALSE){
75+
Zbp[males_idx] <- (bp[males_idx]-mu[males_idx])/11.6032
76+
Zbp[females_idx] <- (bp[females_idx]-mu[females_idx])/10.9573
77+
}
78+
79+
# convert the bp Z-score to a percentile
80+
perc <- round(stats::pnorm(Zbp)*100, digits=2)
81+
82+
return(list(Zbp=Zbp, perc=perc))
83+
84+
}

0 commit comments

Comments
 (0)