# Epifield data management function source
#
# Data management functions designed to modify data.frame
#
# Objective is to produce a very simplified set of command
# for field epidemiologist who are familiar with Epi7 or Stata
#
# http://
#
# Author : Gilles Desve & al...
#
# cryptoagr =aggregate(crypto[,c("count","Year")],by=list(Region=crypto$Region,Sex=crypto$Sex), FUN=sum)
# cryptoagr =aggregate(crypto$count,by=list(Year=crypto$Region), FUN=sum)
# cryptoagg <- aggregate(numberofcases ~ month, FUN = sum, data = crypto2015,na.rm=TRUE)
#' Title
#'
#' @param countvar Variable to be aggregated
#' @param byvar Indicator for wich sum will be calculated
#' @param byvar2 Second Indicator for wich sum will be calculated
#' @param byvar3 Third Indicator for wich sum will be calculated
#'
#' @return aggregated data
#' @export
#'
#' @examples
#' df <- data.frame("count"=c(4,5),"year"=c(2015,2016))
#' sumby(count,year)
sumby <- function(countvar,byvar,byvar2,byvar3 ) {
r <- as.list(match.call())
getvar(r$countvar)
varcount <- getvar()
# dfname <- get_lastdfname()
getvar(r$byvar)
varby <- getvar()
if (!missing(byvar2)) {
getvar(r$byvar2)
varby2 <- getvar()
colvar2 <- paste(",",deparse(getvarname() ))
varby2 <-paste(",", varby2)
} else {varby2<-"";colvar2<-""}
if (!missing(byvar3)) {
getvar(r$byvar3)
varby3 <- getvar()
colvar3 <- paste(",",deparse(getvarname() ) )
varby3 <-paste(",", varby3)
} else {varby3<-"";colvar3<-""}
texpr <- paste("aggregate(",varcount,",by=list(",varby,varby2,varby3,"),FUN=sum,na.rm=TRUE)" )
res = eval(parse(text=texpr))
byvar <- colname(r$byvar)
countvar <- colname(r$countvar)
col.names <- paste("c(",deparse(byvar),colvar2,colvar3,',',deparse(countvar),')')
colnames(res) <- eval(parse(text=col.names))
res
}
#' Title recode a var if a condition if true
#'
#' @param xvar The vector or data.frame column to recode
#' @param oldvalue The value to replace
#' @param newvalue The value to assign
#'
#' @return The recode variable
#' @export
#'
#' @examples
#' recode.if(age, "Unknow", NA)
recode.value <- function(xvar, oldvalue, newvalue) {
r <- as.list(match.call())
vartorec <- getvar(r$xvar)
vartorecname <- getvarname()
if ( is.factor(vartorec) ) {
# we change only the labels...
df <- getlastdf()
dfname <- get_lastdfname()
nl <- nlevels(vartorec)
lev = levels(vartorec)
for (i in 1:nl) {
if (lev[[i]]==oldvalue) {
lev[i] <- newvalue
}
}
recoded <- TRUE
levels(vartorec) <- lev
df[,vartorecname] <- vartorec
push.data(dfname,df)
vartorec
} else {
oldv <- deparse(r$oldvalue)
# test dfname or use error result to find it
condtext <- paste0(vartorecname,"==",oldv)
# vartorecname <- deparse(vartorecname)
# this part is specific to recode value ...
ifexpr <- paste0("recode.if(",vartorecname,",",condtext,",",newvalue,")")
r <- eval(parse(text=ifexpr) )
# recode.if(vartorecname,condtext, newvalue)
invisible(r)
}
}
# recoded <- FALSE
# # test dfname or use error result to find it
#
#
# condresult <- eval_expr(condtext,df)
# continue <- TRUE
#
# if (is.null(condresult)) {
# catret("Logical expression not valid : " , condtext)
# continue <-FALSE
# }
# if ( length(condresult) == 1 ) {
# if ( is.na(condresult) ) {
# continue <- FALSE
# catret("NA returned for: (" , condtext,").", dfname, "unchanged" )
# } else if (is.character(condresult)) {
# continue <- FALSE
# catret("(" , condtext,") doesn't return a logical value.", dfname, "unchanged" )
# }
# }
# if ( continue ) {
# nrec <- sum(condresult)
# if (nrec >0 ) {
# df[condresult,vartorecname] <- value
# recoded <- TRUE
# catret(nrec, "record(s) recoded as",value, "in",dfname, "for ", condtext )
# } else {
# catret("No record for: (" , condtext,").", dfname, "unchanged" )
# }
# }
# if (recoded) {
# push.data(dfname,df)
# }
# invisible(df[,vartorecname])
#' Title
#'
#' @param xvar The numeric variable to recode
#' @param tovar Optionnaly, the new variable to create in the data frame
#' @param by Either a numeric representing the size of each categorie
#' or a vector with the cutoff
#' @param update if TRUE, the default then original data.frame is updated
#'
#' @return The new variable
#' @export
#'
#' @examples
#' recode.by(gastro$age,agegr,by=10)
recode.by <- function(xvar, tovar="", by=10 , update = TRUE) {
r <- as.list(match.call())
vartorec <- getvar(r$xvar)
if (is.null(vartorec)) {
stop()
}
vartorecname <- getvarname()
vartorecfname <- getvar()
df <- getlastdf()
dfname <- get_lastdfname()
labellist <- NULL
if (is.numeric(vartorec)) {
if (length(by)==1) {
minv <- by * min(vartorec)%/%by
maxv <- max(vartorec)
maxv <- maxv + by - maxv%%by
breakslist <- seq(minv,maxv,by)
cutint <-function(x,by) {
t <- paste0(as.character(x),"-",as.character(x+by-1) )
}
labellist <- sapply(breakslist[-length(breakslist)],cutint,by)
} else breakslist <- by
# cut_interval
groupvar <- cut(vartorec,breaks=breakslist, labels=labellist)
tovar <- substitute(tovar)
if (update) {
if (is.data.frame(df)) {
if (! tovar=="") {
cn <- colnames(df)
cn <- c(cn,tovar)
df <- cbind(df,groupvar)
colnames(df) <- cn
} else {
df[,vartorecname] <- groupvar
}
push.data(dfname,df)
}
}
} else {
catret("recode.by only accept numeric vector")
}
invisible(groupvar)
}
#' Title recode a var if a condition if true
#'
#' @param xvar The vector or data.frame column to recode
#' @param condition Logical expression to select value to be recoded
#' @param newvalue The value to replace
#'
#' @return The recoded variable
#' @export
#'
#' @examples
#' recode.if(age, age > 100, 100)
recode.if <- function(xvar, condition, newvalue) {
r <- as.list(match.call())
vartorec <- getvar(r$xvar)
vartorecname <- getvarname()
vartorecfname <- getvar()
r <- try(mcond <- mode(condition),TRUE)
if (inherits(r, "try-error")) {
condtext <- substitute(condition)
condtext <- deparse(condtext)
} else if (mode(condition)=="character") {
condtext <- condition
} else {
condtext <- deparse(condition)
}
newvaluetext <- deparse(newvalue)
recoded <- FALSE
df <- getlastdf()
dfname <- get_lastdfname()
condresult <- eval_expr(condtext,df)
continue <- TRUE
newvar <- vartorec
if (is.null(condresult)) {
catret("Logical expression not valid : " , condtext)
continue <-FALSE
}
if ( length(condresult) == 1 ) {
if ( is.na(condresult) ) {
continue <- FALSE
catret("NA returned for: (" , condtext,").", dfname, "unchanged" )
}
}
if ( continue ) {
nrec <- sum(condresult,na.rm = TRUE)
if (nrec >0 ) {
newcolexpr <- paste0("ifelse(",condtext,",",newvaluetext,",",vartorecfname,")")
newvar <- eval_expr(newcolexpr, df)
if (is.data.frame(df)) {
df[,vartorecname] <- newvar
recoded <- TRUE
}
# expr <- paste0(dfname,'[',condtext,',"',vartorecname,'"] <- ',newvaluetext )
# r <- try(eval(expr, df, .GlobalEnv) , TRUE)
# df[condresult,vartorecname] <- newvalue
catret(nrec, "record(s) recoded as",newvaluetext, "in",vartorecfname, "for", condtext )
} else {
catret("No record for: (" , condtext,").", vartorecfname, "unchanged" )
}
}
if (recoded) {
push.data(dfname,df)
invisible(newvar)
} else invisible(newvar)
}
# Title eval an expression looking at default dataset
#
# @param expr An expression to be evaluated
# @param env An otionnal environnement to evaluate expr
#
# @return Result of expression evaluation
# @export
#
# @examples
# eval_expr(5>4)
eval_expr <- function(expr,env) {
r <- try(mexpr <- mode(expr),TRUE)
if (inherits(r, "try-error")) {
expr <- substitute(expr)
}
mexpr <- mode(expr)
switch(mexpr ,
"character" = {
ex <- expr
} ,
"call" = {
ex <- deparse(expr)
} ,
"name" = {
ex <- as.character(expr)
} ,
{ # else
ex <- deparse(substitute(expr))
}
)
r <- try(eval(parse(text=ex)), TRUE)
m <- NA
last_error(NA)
if (inherits(r, "try-error")) {
# it's not a correct formula ... we store the error
# and we may try to extract the var in error and find them
m <- r[[1]]
last_error(m)
r <- NA
# if env is not specified we try to get the default dataset (see setdata())
if (missing(env)) { env <- getdata() }
if (is.data.frame(env)) {
# and try to do better by evaluating in the context of current dataset
m <- NA
last_error(m)
r <- try(eval(parse(text=ex), env, parent.frame()) , TRUE)
if (inherits(r, "try-error")) {
# still an error we store them
m <- r[[1]]
last_error(m)
r <- NA
}
}
}
# if (! is.na(m)) {
# catret(m)
# }
# we return the result
r
}
#' @title List data.frame column
#'
#' @param df A data.frame
#'
#' @return Structure of data.frame column
#' @export
#'
#' @examples
#' describe(test)
describe <- function(df) {
fileatt <- dim(df)
dfn <- substitute(df)
catret(fileatt[1],
"Observations of ",
fileatt[2],
" variables. Use str(",dfn,") for details")
r1 <- colnames(df)
ldf <- length(r1)
r2 <- sapply(df,class)
r3 <- attr(df,"var.labels")
if (is.null(r3)) {
r3 <- vector("character",length = ldf)
}
r4 <- sapply(df,levels)
r5 <- vector("character",length = ldf)
for (i in 1:ldf) {
# toString to be tested ...
r5[i] <- paste(r4[[i]],sep = " ",collapse= ",")
}
r <- cbind(type=r2,desc=r3,labels=r5)
r
}
#' @title List head of data.frame allowing to select column to view
#'
#' @param ... variable name to include in list
#' @param nline Number of rows to show (default to n) If negative then number of row from the end
#'
#' @return the resulting list
#' @export
#'
#' @examples
#' \dontrun{
#' view(age,case)
#' view(age,case, nline=5)
#' view(age,case, nline= -10)
#' }
view <- function(...,nline=10) {
r <- as.list(match.call())
n <- names(r)
i <-pmatch("nline",n, nomatch = 0)
if (i > 0) {
r[i] <- NULL
}
l <- length(r)
c <- vector()
j <- 0
for (i in 2:l) {
j <- j+1
c[j]<- as.character(r[i])
}
df <- getdata()
if (nline > 0) {
res <- df[1:nline,c]
} else {
l <- nrow(df)
nline <- l + nline
res <- df[nline:l,c]
}
res
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.