# INTERPRET ################### interpret takes a vector and makes a data.frame out of it (to be used in e.g. make.ovariable). ### It also changes abbreviations into probability samples. # Lognormal distribution parametrization functions lmean <- function(parmean, parsd) {return(log(parmean)-log(1+(parsd^2)/(parmean^2))/2)} lsd <- function(parmean, parsd) {return(log(1+(parsd^2)/(parmean^2)))} # Actual interpretation function. Takes already pre-processed information and returns a distribution. This is a separate function because # it isn't vectorizable (easily anyway). interpf <- function( n, res.char, brackets.pos, brackets.length, minus.length, minus.exists, plusminus, plusminus.length, plusminus.pos, doublePoint, minus.relevant, fromzero, dbug = FALSE ) { if(doublePoint[1] > 0) { tempArgs <- sort(as.numeric(unlist(strsplit(res.char, "\\:")))) if(dbug) cat("Triangular distribution. \n") if (n == 0) { if (tempArgs[1] + tempArgs[3] == 2 * tempArgs[2]) { return(tempArgs[2]) } else if (tempArgs[1] + tempArgs[3] > 2 * tempArgs[2]) { return(tempArgs[1] + ((tempArgs[3]-tempArgs[1])(tempArgs[2]-tempArgs[1])/2)^(1/2)) } else { return(tempArgs[3] - ((tempArgs[3]-tempArgs[1])(tempArgs[3]-tempArgs[2])/2)^(1/2)) } } else { return(rtriangle(n,tempArgs[1],tempArgs[3],tempArgs[2])) } } if(brackets.pos > 0) { n.minus.inside.brackets <- sum(minus.relevant > brackets.pos & minus.relevant < brackets.pos + brackets.length) imean <- as.numeric(substr(res.char, 1, brackets.pos - 1)) if (n == 0) { return(imean) } if(n.minus.inside.brackets == 1) { ici <- c(as.numeric(substr(res.char, brackets.pos + 1, minus.relevant[minus.relevant > brackets.pos] - 1)), as.numeric(substr(res.char, minus.relevant[minus.relevant > brackets.pos] + 1, brackets.pos + brackets.length - 2))) if((ici[2] - imean) / (imean - ici[1]) < 1.5) { if(dbug) cat("Normal distribution. \n") isd <- sum(abs(ici - imean) / 2) / qnorm(0.975) return(rnorm(n, imean, isd)) } else { if(dbug) cat("Lognormal distribution. \n") isd <- sum(abs(log(ici) - log(imean)) / 2) / qnorm(0.975) return(exp(rnorm(n, log(imean), isd))) } } if(n.minus.inside.brackets %in% c(2,3)) { ici <- c(as.numeric(substr(res.char, brackets.pos + 1, minus.relevant[minus.relevant > brackets.pos][2] - 1)), as.numeric(substr(res.char, minus.relevant[minus.relevant > brackets.pos][2] + 1, brackets.pos + brackets.length - 2))) isd <- sum(abs(ici - imean) / 2) / qnorm(0.975) if(dbug) cat("Normal distribution. \n") return(rnorm(n, imean, isd)) } warning(paste("Unable to interpret \"", res.char, "\"", sep = "")) return(rep(NA, n)) } if(plusminus.pos > 0) { imean <- as.numeric(substr(res.char, 1, plusminus.pos - 1)) if (n == 0) { return(imean) } if(dbug) cat("Normal distribution. \n") return(rnorm(n, imean, as.numeric(substr(res.char, plusminus.pos + plusminus.length, nchar(res.char))))) } if(minus.exists) { if(length(minus.relevant) == 1) { a <- as.numeric(substr(res.char, 1, minus.relevant - 1)) b <- as.numeric(substr(res.char, minus.relevant + 1, nchar(res.char))) if(a / b >= 1/100 | a == 0) { if(dbug) cat("Uniform distribution. \n") if (n == 0) { return((a+b)/2) } return(runif(n, a, b)) } else { if(dbug) cat("Loguniform distribution. \n") if (n == 0) { return(exp((log(a)+log(b))/2)) } return(exp(runif(n, log(a), log(b)))) } } if(length(minus.relevant) %in% c(2,3)) { # If there is more than one '-' we're porbably dealing with negative boundaries. (More than 3 will produce NAs.) if(dbug) cat("Uniform distribution. \n") # Assume that negative number is always first. a <- as.numeric(substr(res.char, 1, minus.relevant[2] - 1)) b <- as.numeric(substr(res.char, minus.relevant[2] + 1, nchar(res.char))) if (n == 0) { return((a+b)/2) } return(runif(n, a, b)) } } if(sum(unlist(strsplit(res.char, ""))==";") > 0) { if(dbug) cat("Discrete random samples. \n") a <- as.numeric(unlist(strsplit(res.char, ";"))) if (n == 0) { return(mean(a)) } return(sample(a, n, replace = TRUE)) } if(fromzero[[1]][1] == 1) { temp <- interpret( paste("0-", substr(res.char, 2, nchar(res.char)), sep = ""), n, dbug = dbug ) return( temp\$Result ) } warning(paste("Unable to interpret \"", res.char, "\"", sep = "")) return(rep(NA, n)) } # The following function processes character strings and loops the interpretation function. input.interp <- function(res.char, n = 1000, dbug = FALSE) { res.char <- gsub(" ", "", res.char) res.char <- gsub(",", ".", res.char) plusminus <- gregexpr(paste("\\+-|", rawToChar(as.raw(177)), sep = ""), res.char) plusminus.length <- as.numeric(unlist(sapply(plusminus, attributes))) plusminus.pos <- unlist(plusminus) minus <- gregexpr("-", res.char) e <- gregexpr("e-|E-", res.char) # ignore negative signs in exponents when data is given in form 1e-27 for (i in 1:length(minus)){ minus[[i]] <- minus[[i]][!(minus[[i]] %in% (e[[i]] + 1))] } minus.length <- sapply(minus, length) minus.exists <- unlist(minus)[cumsum(c(0, minus.length[-length(minus.length)])) + 1] > 0 brackets <- gregexpr("\\(.*\\)", res.char) # matches for brackets "(...)" brackets.length <- as.numeric(unlist(sapply(brackets, attributes)[1,])) brackets.pos <- unlist(brackets) doublePoint <- gregexpr(":", res.char) fromzero <- gregexpr("<", res.char) out <- list() for(i in 1:length(res.char)) { if(res.char[i] %in% c("NA") | nchar(gsub(" ", "", res.char[i])) == 0) { out[[i]] <- NA } else { val <- suppressWarnings(as.numeric(res.char[i])) if(is.na(val)) { minus.relevant <- unlist(minus)[(cumsum(c(0, minus.length)) + 1)[i]:cumsum(minus.length)[i]] out[[i]] <- interpf(n, res.char[i], brackets.pos[i], brackets.length[i], minus.length[i], minus.exists[i], plusminus[[i]], plusminus.length[i], plusminus.pos[i], doublePoint[[i]], minus.relevant, fromzero[i], dbug ) } else out[[i]] <- val } } if (any(sapply(out, length) > 1)) { for(i in 1:length(res.char)) { if (length(out[[i]]) == 1) { out[[i]] <- rep(out[[i]], n) } } } out } # Assisting function for data.frame wrapper. f.iter <- function(x) { 1:x } # Data.frame wrapper for the functions. interpret <- function(idata, N = NULL, rescol = "Result", dbug = FALSE, ...) { if (length(N) == 0) N <- get("N", envir = openv) # use custom environment variable N if not given if (!is.data.frame(idata)) idata <- as.data.frame(idata) if (ncol(idata) == 0) stop("Empty data.frame!") if (!rescol %in% colnames(idata)) stop(paste("No \"", rescol, "\" column found", sep = "")) temp <- input.interp(idata[[rescol]], N, dbug) temp.lengths <- sapply(temp, length) if (ncol(idata) == 1) { out <- list() out[[rescol]] <- unlist(temp) out <- as.data.frame(out) } else { out <- data.frame(idata[rep(1:nrow(idata), times = temp.lengths),]) out[[rescol]] <- unlist(temp) } if (prod(temp.lengths) > 1) { dim(temp.lengths) <- length(temp.lengths) out\$Iter<- c(apply(temp.lengths, 1, f.iter)) } return(out) } setGeneric("interpret") setMethod( f = "interpret", signature = signature(idata = "character"), definition = function(idata, N = NULL, dbug = FALSE) { callGeneric(data.frame(Result = idata), N = N, dbug = dbug) } ) setMethod( f = "interpret", signature = signature(idata = "numeric"), definition = function(idata, N = NULL, dbug = FALSE) { return(data.frame(Iter = 1:length(idata), Result = idata)) } ) #setMethod( # f = "interpret", # signature = signature(idata = "interpret"), # definition = function(idata, N = 1000, dbug = FALSE) { # callGeneric(data.frame(Result = idata), N = N, dbug = dbug) # } #) # Interpreting empty locations in indices # fillna takes a data.frame and fills the cells with NA with each level in that column. # object is the data.frame, marginals is a vector of columns (either column names or positions) that are to be filled. # This version of fillna accepts column positions (as the previous version) and also column names in marginals. fillna <- function (object, marginals) { a <- dropall(object) if(!is.numeric(marginals)) marginals <- match(marginals, colnames(object)) for (i in marginals) { a[[i]] <- as.factor(a[[i]]) a1 <- a[!is.na(a[[i]]), ] a2 <- a[is.na(a[[i]]), ][-i] addition <- data.frame(A = levels(a[[i]])) colnames(addition) <- colnames(a)[i] a2 <- merge(addition, a2) a <- rbind(a1, a2) } return(a) } is.na.ext <- function(x){ a <- is.na(x) | x == "NA" | nchar(gsub(" ", "", x)) == 0 | x == "*" return(a) } # Fill NAs in matching columns in x with union of locations in x and y # Compare to fill.na which replaces NA with own fill.na.merge <- function(x, y) { common <- intersect(colnames(x@output), colnames(y@output)) locs <- list() # Loop through common columns for (i in common) { testx <- is.na.ext(x@output[i]) testy <- is.na.ext(y@output[i]) # For x if (any(testx)) { locs[[i]] <- union(levels(as.factor(x@output[[i]])), levels(as.factor(y@output[[i]]))) if (length(locs[[i]]) > 1) { # Duplicate rows with wildcards temp <- ifelse(testx, length(locs[[i]]), 1) ind <- rep(1:length(temp), temp) x@output <- x@output[ind,] # Insert locations to duplicated rows duplicates <- rep(testx, temp) temp <- as.character(x@output[[i]]) # Since number of duplicates is fixed to length of locs this essentially repeats locs # as many times as there are wildcards in this particular index at the moment. temp[duplicates] <- locs[[i]] x@output[[i]] <- factor(temp) } } # For y if (any(testy)) { if (length(locs[[i]]) == 0) { locs[[i]] <- union(levels(as.factor(x@output[[i]])), levels(as.factor(y@output[[i]]))) } if (length(locs[[i]]) > 1) { # Duplicate rows with wildcards temp <- ifelse(testy, length(locs[[i]]), 1) ind <- rep(1:length(temp), temp) y@output <- y@output[ind,] # Insert locations to duplicated rows duplicates <- rep(testy, temp) temp <- as.character(y@output[[i]]) temp[duplicates] <- locs[[i]] y@output[[i]] <- factor(temp) } } } return(list(x, y)) } #interpret("500(490-5000)", N = 2, dbug= TRUE) #interpret("1;2;3;4", N = 20, dbug = TRUE) #interpret("<9", N = 4, dbug = TRUE)