# Helper and supporting functions for the EAB survival analysis script # computes the lateral area of a truncated cone. Used to determine the surface # area of the sampled bolts computeLateralAreaTruncatedCone <- function( r1 = 0.0, r2 = 0.0, h = 0.0) { ifelse( r1 > r2, rBig <- r1, rBig <- r2) # the larger value to R, ifelse( r1 > r2, rSmall <- r2, rSmall <- r1) # and the smaller value to r # compute the slant height and the lateral area s <- sqrt( h^2 + (rBig - rSmall)^2) # slant height lateralArea <- pi * (rBig + rSmall) * s return(lateralArea) } # checks if the one diamater is twice the size of the other diameter # indication of a data entry error. diamCheck <- function( diam1, diam2) { ifelse( diam1 > diam2, dBig <- diam1, dBig <- diam2) # the larger value to dBig, ifelse( diam1 > diam2, dSmall <- diam2, dSmall <- diam1) # and the smaller value to dSmall # if the difference is twice the small diameter, flag the error for inspection ifelse( (dBig - dSmall) > (0.5*dSmall), response <- "TRUE", response <- "FALSE") return(response) } # computes the stage specific survivial when passed two vectors of stages # and densitiess survivalFunction <- function( stages, densities ) { if ( length(stages) == 1) { # if only one stage passed return NA out <- NA } else { # create a data frame of stages, densities and lagged # densities x <- data.frame( j = stages , nj = densities, nj1 = c( densities[2:length(densities)], NA) ) # compute the numerical difference between each stage number # and the log survival rate (Hj) following method of # Royama (1984) x <- transform( x, diffj = c( diff(j), NA) , Hj = log(nj1) - log(nj) ) # Hj values calculated between stages that are >1 step # apart are non-sensical. Set these values to NA x$Hj[ x$diffj > 1] <- NA out <- x$Hj } return(out) } # function for computing some mean diameters. conditionalMean <- function( obs = c(0, 1,2,3,4,5) ) { # computes the mean of all vector using all values > 0 #check for NA's and returns NA if any values in the vector are NA if( is.na(sum(obs)) == TRUE ) { values <- NA } else { # check if the vector is all 0s, if so report 0 if(sum(obs) == 0 ) { values <- 0 } else { values <- mean( obs[ obs > 0]) } } return (values) } # old broken functions # computeLateralAreaTruncatedCone <- function( r1 = 0.0, r2 = 0.0, h = 0.0) { # if NA values are passed sets the radius and height values to 0 which forces # the function to return NA # if ( is.na( r1 & r2 & h) == TRUE ) { # lateralArea <- NA # } else { # check if radii and height values are all sensical i.e., > 0 # if ( r1 > 0.0 & r2 > 0.0 & h > 0.0 ) { # # # set the radii so that the larger value is set as R # if (r1 > r2) { # R <- r1 # r <- r2 # } else { # R <- r2 # r <- r1 # } # # compute the slant height and the lateral area # s <- sqrt( h^2 + (R - r)^2) # slant height # lateralArea <- pi * (R + r) * s # } else { # lateralArea <- 0 # } #} # return(lateralArea) #} #within( test.frame <- data.frame( height = c(1, 1:5, 0, 0, NA, 1), # radius1 = c(0, 2:6, NA, 0, NA, 0), # radius2 = c(0, 3:7, NA, 0, NA, 0) ), # lateralareas <- computeLateralAreaTruncatedCone (h = height, # r1 = radius1, # r2 = radius2) ) #test.frame$lateralAreas <- computeLateralAreaTruncatedCone( # h = test.frame$height, # r1 = test.frame$radius1, # r2 = test.frame$radius2)