child_bp_percentile_v0.9.r

bp_perc <- function (data, male="M", female="F", sbp="sbp", dbp="dbp", ht_perc="ht_perc", age="age", sex="sex")
  {
# Author: Matt Cooper
# Version 0.9
# Last updated: 29/04/10
# Blood Pressure Percentiles in Children and Adolescents, written for R
# http://www.nhlbi.nih.gov/guidelines/hypertension/child_tbl.htm

# Default values for males and females are "M" and "F" respectively, this can be specified by the user
# Key variable names are assumed to be all in lower case, this can be specified by the user

# Note:
# 'ht_perc' vector should be a character not a factor, taking only the values "5th","10th","25th","50th","75th","90th" and "95th"
# use 'child_height_percentile_v0.9.r' or later to create this vector
# currently age is rounded using a 'swedish rounding' type system, 3.4 will become 3 while 3.6 will become 4
# if you feel this is not appropriate then please set your age column to 0 dp using the rule you would prefer
# prior to submitting

# Pulling out required data into vectors

  age <- round(data[,age],0)
  ht_perc <- data[,ht_perc]
  sbp <- data[,sbp]
  dbp <- data[,dbp]
  sex <- data[,sex]
  sbp_perc <- rep(NA, nrow(data))
  dbp_perc <- rep(NA, nrow(data))
  
#  age <- round(data[,"age"],0)
#  ht_perc <- data[,"ht_percent"]
#  sbp <- data[,"sbp"]
#  dbp <- data[,"dbp"]
#  sex <- data[,"sex"]
#  sbp_perc <- vector()
#  dbp_perc <- vector()

# Function checks

  if(any(age < 1 | age > 17)) stop("You have one or more subjects in your dataset younger than 1 year or older than 17 years, please remove and resubmit.", call.=F)

# Set up WC percentile lookup matrix

mbpp <- as.data.frame(matrix(c(
1,"50th",80,81,83,85,87,88,89,34,35,36,37,38,39,39,
"","90th",94,95,97,99,100,102,103,49,50,51,52,53,53,54,
"","95th",98,99,101,103,104,106,106,54,54,55,56,57,58,58,
"","99th",105,106,108,110,112,113,114,61,62,63,64,65,66,66,
2,"50th",84,85,87,88,90,92,92,39,40,41,42,43,44,44,
"","90th",97,99,100,102,104,105,106,54,55,56,57,58,58,59,
"","95th",101,102,104,106,108,109,110,59,59,60,61,62,63,63,
"","99th",109,110,111,113,115,117,117,66,67,68,69,70,71,71,
3,"50th",86,87,89,91,93,94,95,44,44,45,46,47,48,48,
"","90th",100,101,103,105,107,108,109,59,59,60,61,62,63,63,
"","95th",104,105,107,109,110,112,113,63,63,64,65,66,67,67,
"","99th",111,112,114,116,118,119,120,71,71,72,73,74,75,75,
4,"50th",88,89,91,93,95,96,97,47,48,49,50,51,51,52,
"","90th",102,103,105,107,109,110,111,62,63,64,65,66,66,67,
"","95th",106,107,109,111,112,114,115,66,67,68,69,70,71,71,
"","99th",113,114,116,118,120,121,122,74,75,76,77,78,78,79,
5,"50th",90,91,93,95,96,98,98,50,51,52,53,54,55,55,
"","90th",104,105,106,108,110,111,112,65,66,67,68,69,69,70,
"","95th",108,109,110,112,114,115,116,69,70,71,72,73,74,74,
"","99th",115,116,118,120,121,123,123,77,78,79,80,81,81,82,
6,"50th",91,92,94,96,98,99,100,53,53,54,55,56,57,57,
"","90th",105,106,108,110,111,113,113,68,68,69,70,71,72,72,
"","95th",109,110,112,114,115,117,117,72,72,73,74,75,76,76,
"","99th",116,117,119,121,123,124,125,80,80,81,82,83,84,84,
7,"50th",92,94,95,97,99,100,101,55,55,56,57,58,59,59,
"","90th",106,107,109,111,113,114,115,70,70,71,72,73,74,74,
"","95th",110,111,113,115,117,118,119,74,74,75,76,77,78,78,
"","99th",117,118,120,122,124,125,126,82,82,83,84,85,86,86,
8,"50th",94,95,97,99,100,102,102,56,57,58,59,60,60,61,
"","90th",107,109,110,112,114,115,116,71,72,72,73,74,75,76,
"","95th",111,112,114,116,118,119,120,75,76,77,78,79,79,80,
"","99th",119,120,122,123,125,127,127,83,84,85,86,87,87,88,
9,"50th",95,96,98,100,102,103,104,57,58,59,60,61,61,62,
"","90th",109,110,112,114,115,117,118,72,73,74,75,76,76,77,
"","95th",113,114,116,118,119,121,121,76,77,78,79,80,81,81,
"","99th",120,121,123,125,127,128,129,84,85,86,87,88,88,89,
10,"50th",97,98,100,102,103,105,106,58,59,60,61,61,62,63,
"","90th",111,112,114,115,117,119,119,73,73,74,75,76,77,78,
"","95th",115,116,117,119,121,122,123,77,78,79,80,81,81,82,
"","99th",122,123,125,127,128,130,130,85,86,86,88,88,89,90,
11,"50th",99,100,102,104,105,107,107,59,59,60,61,62,63,63,
"","90th",113,114,115,117,119,120,121,74,74,75,76,77,78,78,
"","95th",117,118,119,121,123,124,125,78,78,79,80,81,82,82,
"","99th",124,125,127,129,130,132,132,86,86,87,88,89,90,90,
12,"50th",101,102,104,106,108,109,110,59,60,61,62,63,63,64,
"","90th",115,116,118,120,121,123,123,74,75,75,76,77,78,79,
"","95th",119,120,122,123,125,127,127,78,79,80,81,82,82,83,
"","99th",126,127,129,131,133,134,135,86,87,88,89,90,90,91,
13,"50th",104,105,106,108,110,111,112,60,60,61,62,63,64,64,
"","90th",117,118,120,122,124,125,126,75,75,76,77,78,79,79,
"","95th",121,122,124,126,128,129,130,79,79,80,81,82,83,83,
"","99th",128,130,131,133,135,136,137,87,87,88,89,90,91,91,
14,"50th",106,107,109,111,113,114,115,60,61,62,63,64,65,65,
"","90th",120,121,123,125,126,128,128,75,76,77,78,79,79,80,
"","95th",124,125,127,128,130,132,132,80,80,81,82,83,84,84,
"","99th",131,132,134,136,138,139,140,87,88,89,90,91,92,92,
15,"50th",109,110,112,113,115,117,117,61,62,63,64,65,66,66,
"","90th",122,124,125,127,129,130,131,76,77,78,79,80,80,81,
"","95th",126,127,129,131,133,134,135,81,81,82,83,84,85,85,
"","99th",134,135,136,138,140,142,142,88,89,90,91,92,93,93,
16,"50th",111,112,114,116,118,119,120,63,63,64,65,66,67,67,
"","90th",125,126,128,130,131,133,134,78,78,79,80,81,82,82,
"","95th",129,130,132,134,135,137,137,82,83,83,84,85,86,87,
"","99th",136,137,139,141,143,144,145,90,90,91,92,93,94,94,
17,"50th",114,115,116,118,120,121,122,65,66,66,67,68,69,70,
"","90th",127,128,130,132,134,135,136,80,80,81,82,83,84,84,
"","95th",131,132,134,136,138,139,140,84,85,86,87,87,88,89,
"","99th",139,140,141,143,145,146,147,92,93,93,94,95,96,97
),nrow=68, ncol=16, byrow=T),stringsAsFactors=F)

names(mbpp) <- c("","","5th","10th","25th","50th","75th","90th","95th","5th","10th","25th","50th","75th","90th","95th")

fbpp <- as.data.frame(matrix(c(
1,"50th",83,84,85,86,88,89,90,38,39,39,40,41,41,42,
"","90th",97,97,98,100,101,102,103,52,53,53,54,55,55,56,
"","95th",100,101,102,104,105,106,107,56,57,57,58,59,59,60,
"","99th",108,108,109,111,112,113,114,64,64,65,65,66,67,67,
2,"50th",85,85,87,88,89,91,91,43,44,44,45,46,46,47,
"","90th",98,99,100,101,103,104,105,57,58,58,59,60,61,61,
"","95th",102,103,104,105,107,108,109,61,62,62,63,64,65,65,
"","99th",109,110,111,112,114,115,116,69,69,70,70,71,72,72,
3,"50th",86,87,88,89,91,92,93,47,48,48,49,50,50,51,
"","90th",100,100,102,103,104,106,106,61,62,62,63,64,64,65,
"","95th",104,104,105,107,108,109,110,65,66,66,67,68,68,69,
"","99th",111,111,113,114,115,116,117,73,73,74,74,75,76,76,
4,"50th",88,88,90,91,92,94,94,50,50,51,52,52,53,54,
"","90th",101,102,103,104,106,107,108,64,64,65,66,67,67,68,
"","95th",105,106,107,108,110,111,112,68,68,69,70,71,71,72,
"","99th",112,113,114,115,117,118,119,76,76,76,77,78,79,79,
5,"50th",89,90,91,93,94,95,96,52,53,53,54,55,55,56,
"","90th",103,103,105,106,107,109,109,66,67,67,68,69,69,70,
"","95th",107,107,108,110,111,112,113,70,71,71,72,73,73,74,
"","99th",114,114,116,117,118,120,120,78,78,79,79,80,81,81,
6,"50th",91,92,93,94,96,97,98,54,54,55,56,56,57,58,
"","90th",104,105,106,108,109,110,111,68,68,69,70,70,71,72,
"","95th",108,109,110,111,113,114,115,72,72,73,74,74,75,76,
"","99th",115,116,117,119,120,121,122,80,80,80,81,82,83,83,
7,"50th",93,93,95,96,97,99,99,55,56,56,57,58,58,59,
"","90th",106,107,108,109,111,112,113,69,70,70,71,72,72,73,
"","95th",110,111,112,113,115,116,116,73,74,74,75,76,76,77,
"","99th",117,118,119,120,122,123,124,81,81,82,82,83,84,84,
8,"50th",95,95,96,98,99,100,101,57,57,57,58,59,60,60,
"","90th",108,109,110,111,113,114,114,71,71,71,72,73,74,74,
"","95th",112,112,114,115,116,118,118,75,75,75,76,77,78,78,
"","99th",119,120,121,122,123,125,125,82,82,83,83,84,85,86,
9,"50th",96,97,98,100,101,102,103,58,58,58,59,60,61,61,
"","90th",110,110,112,113,114,116,116,72,72,72,73,74,75,75,
"","95th",114,114,115,117,118,119,120,76,76,76,77,78,79,79,
"","99th",121,121,123,124,125,127,127,83,83,84,84,85,86,87,
10,"50th",98,99,100,102,103,104,105,59,59,59,60,61,62,62,
"","90th",112,112,114,115,116,118,118,73,73,73,74,75,76,76,
"","95th",116,116,117,119,120,121,122,77,77,77,78,79,80,80,
"","99th",123,123,125,126,127,129,129,84,84,85,86,86,87,88,
11,"50th",100,101,102,103,105,106,107,60,60,60,61,62,63,63,
"","90th",114,114,116,117,118,119,120,74,74,74,75,76,77,77,
"","95th",118,118,119,121,122,123,124,78,78,78,79,80,81,81,
"","99th",125,125,126,128,129,130,131,85,85,86,87,87,88,89,
12,"50th",102,103,104,105,107,108,109,61,61,61,62,63,64,64,
"","90th",116,116,117,119,120,121,122,75,75,75,76,77,78,78,
"","95th",119,120,121,123,124,125,126,79,79,79,80,81,82,82,
"","99th",127,127,128,130,131,132,133,86,86,87,88,88,89,90,
13,"50th",104,105,106,107,109,110,110,62,62,62,63,64,65,65,
"","90th",117,118,119,121,122,123,124,76,76,76,77,78,79,79,
"","95th",121,122,123,124,126,127,128,80,80,80,81,82,83,83,
"","99th",128,129,130,132,133,134,135,87,87,88,89,89,90,91,
14,"50th",106,106,107,109,110,111,112,63,63,63,64,65,66,66,
"","90th",119,120,121,122,124,125,125,77,77,77,78,79,80,80,
"","95th",123,123,125,126,127,129,129,81,81,81,82,83,84,84,
"","99th",130,131,132,133,135,136,136,88,88,89,90,90,91,92,
15,"50th",107,108,109,110,111,113,113,64,64,64,65,66,67,67,
"","90th",120,121,122,123,125,126,127,78,78,78,79,80,81,81,
"","95th",124,125,126,127,129,130,131,82,82,82,83,84,85,85,
"","99th",131,132,133,134,136,137,138,89,89,90,91,91,92,93,
16,"50th",108,108,110,111,112,114,114,64,64,65,66,66,67,68,
"","90th",121,122,123,124,126,127,128,78,78,79,80,81,81,82,
"","95th",125,126,127,128,130,131,132,82,82,83,84,85,85,86,
"","99th",132,133,134,135,137,138,139,90,90,90,91,92,93,93,
17,"50th",108,109,110,111,113,114,115,64,65,65,66,67,67,68,
"","90th",122,122,123,125,126,127,128,78,79,79,80,81,81,82,
"","95th",125,126,127,129,130,131,132,82,83,83,84,85,85,86,
"","99th",133,133,134,136,137,138,139,90,90,91,91,92,93,93
),nrow=68, ncol=16, byrow=T),stringsAsFactors=F)

names(fbpp) <- c("","","5th","10th","25th","50th","75th","90th","95th","5th","10th","25th","50th","75th","90th","95th")

# Loop to calculate SBP percentiles
  for(i in 1:nrow(data))
    {
    if(!is.na(ht_perc[i]) & !is.na(sbp[i]))
      {# Females
        if(sex[i]==female)
          {
          temp <- which(names(fbpp)[3:9]==ht_perc[i])
          rown <- which(fbpp[,1]==age[i])
          pick <-sum(sbp[i] >= as.numeric(fbpp[rown:(rown+3),2+temp]))
          if(pick==0){sbp_perc[i] <- "<50th"}else{sbp_perc[i] <- fbpp[rown+pick-1,2]}
          }
        # Males
        if(sex[i]==male)
          {
          temp <- which(names(mbpp)[3:9]==ht_perc[i])
          rown <- which(mbpp[,1]==age[i])
          pick <-sum(sbp[i] >= as.numeric(mbpp[rown:(rown+3),2+temp]))
          if(pick==0){sbp_perc[i] <- "<50th"}else{sbp_perc[i] <- mbpp[rown+pick-1,2] }
          }
      }
    }

# Loop to calculate DBP percentiles

  for(i in 1:nrow(data))
    {
    if(!is.na(ht_perc[i]) & !is.na(dbp[i]))
      {# Females
        if(sex[i]==female)
          {
          temp <- which(names(fbpp)[10:16]==ht_perc[i])
          rown <- which(fbpp[,1]==age[i])
          pick <-sum(dbp[i] >= as.numeric(fbpp[rown:(rown+3),9+temp]))
          if(pick==0){dbp_perc[i] <- "<50th"}else{dbp_perc[i] <- fbpp[rown+pick-1,2]}
          }
        # Males
        if(sex[i]==male)
          {
          temp <- which(names(mbpp)[10:16]==ht_perc[i])
          rown <- which(mbpp[,1]==age[i])
          pick <-sum(dbp[i] >= as.numeric(mbpp[rown:(rown+3),9+temp]))
          if(pick==0){dbp_perc[i] <- "<50th"}else{dbp_perc[i] <- mbpp[rown+pick-1,2]}
          }
      }
    }

          output <- cbind(sbp_perc,dbp_perc)
         return(output)
#         }
  }