Ipw new

R/check_input.R

@@ -0,0 +1,97 @@
+check_exposure <- function(exposure, family) {
+  unique_vals <- unique(exposure)
+  num_unique_vals <- length(unique_vals)
+
+  if (family == "binomial") {
+    # Binomial check: binary values (0, 1) or two levels if factor
+    if (num_unique_vals > 2) {
+      stop(paste(
+        "Error: For family 'binomial', the 'exposure' variable must be binary with only two unique values.\n",
+        "Currently, it has", num_unique_vals, "unique values:", 
+        paste(unique_vals, collapse = ", "), "."
+      ))
+    } else if (num_unique_vals == 1) {
+      warning("Warning: The 'exposure' variable contains only one unique value.\n Hence there is no contrast. Ensure this is intentional.")
+    }
+    if (is.numeric(exposure)) {
+      non_binary_vals <- unique_vals[!unique_vals %in% c(0, 1)]
+      if (length(non_binary_vals) > 0) {
+        stop(paste(
+          "Error: Numeric 'exposure' values must be either 0 or 1.\n",
+          "Found invalid values:", paste(non_binary_vals, collapse = ", "), "."
+        ))
+      }
+    } else if (is.factor(exposure)) {
+      if (length(levels(exposure)) != 2) {
+        stop("Error: The factor 'exposure' must have exactly two levels.")
+      }
+      exposure <- as.numeric(exposure) - 1
+    } else {
+      stop("Error: non-numeric 'exposure' variable must be converted to a factor before use.")
+    }
+  }
+
+  else if (family == "survival") {
+    # Survival check: status indicator (0 for alive, 1 for dead, etc.)
+    if (num_unique_vals > 2) {
+      stop(paste(
+        "Error: For family 'survival', the 'exposure' variable must be binary with only two unique values.\n",
+        "Currently, it has", num_unique_vals, "unique values:", 
+        paste(unique_vals, collapse = ", "), "."
+      ))
+    } else if (num_unique_vals == 1) {
+      warning("Warning: The 'exposure' variable contains only one unique value.\n Hence there is no contrast. Ensure this is intentional.")
+    }
+
+    if (!is.numeric(exposure) && !is.logical(exposure) && !is.factor(exposure)) {
+      stop("Error: For family 'survival', 'exposure' should be a numeric, logical, or factor variable representing the status indicator.")
+    }
+
+    if (is.numeric(exposure)) {
+      # Check for valid numeric status indicators
+      if (!all(unique_vals %in% c(0,1)) & !all(unique_vals  %in% c(1,2))) {
+        stop(paste(
+          "Error: For family 'survival', numeric 'exposure' values must be (0 and 1) or (1 and 2).\n",
+          "Found invalid values:", paste(unique_vals, collapse = ", "), "."
+        ))
+      }
+    } else if (is.logical(exposure)) {
+      # Convert logical TRUE/FALSE to numeric
+      exposure <- as.numeric(exposure)
+    } else if (is.factor(exposure)) {
+      # Convert factor to numeric and check levels
+      exposure <- as.numeric(exposure)
+    }
+  }
+
+  else if (family == "multinomial") {
+    # Multinomial check: categorical variable with more than 2 unique values
+    if (num_unique_vals <= 2) {
+      stop("Error: For family 'multinomial', 'exposure' must have more than two unique values.")
+    }
+  }
+
+  else if (family == "ordinal") {
+    # Ordinal check: ordered factor variable with more than 2 levels
+    if (!is.factor(exposure)) {
+      stop("Error: For family 'ordinal', 'exposure' should be a factor.")
+    }
+    if (num_unique_vals <= 2) {
+      stop("Error: For family 'ordinal', 'exposure' must have more than two unique values.")
+    }
+  }
+
+  else if (family == "gaussian") {
+    # Gaussian check: continuous numeric variable
+    if (!is.numeric(exposure)) {
+      stop("Error: For family 'gaussian', 'exposure' should be a continuous numeric variable.")
+    }
+  }
+
+  else {
+    stop("Error: Unknown family. Choose one of 'binomial', 'survival', 'multinomial', 'ordinal', or 'gaussian'.")
+  }
+
+  # Return the modified or validated exposure variable
+  return(exposure)
+}

R/ipwpoint.R

@@ -11,27 +11,60 @@ ipwpoint <- function(
 		#save input
 			tempcall <- match.call()
 		#some basic input checks
-			if (!("exposure" %in% names(tempcall))) stop("No exposure variable specified")
-			if (!("family" %in% names(tempcall)) | ("family" %in% names(tempcall) & !(tempcall$family %in% c("binomial", "multinomial", "ordinal", "gaussian")))) stop("No valid family specified (\"binomial\", \"multinomial\", \"ordinal\", \"gaussian\")")
-			if (tempcall$family == "binomial") {if(!(tempcall$link %in% c("logit", "probit", "cauchit", "log", "cloglog"))) stop("No valid link function specified for family = binomial (\"logit\", \"probit\", \"cauchit\", \"log\", \"cloglog\")")}
-			if (tempcall$family == "ordinal" ) {if(!(tempcall$link %in% c("logit", "probit", "cauchit", "cloglog"))) stop("No valid link function specified for family = binomial (\"logit\", \"probit\", \"cauchit\", \"cloglog\")")}
-			if (!("denominator" %in% names(tempcall))) stop("No denominator model specified")
-			if (!is.null(tempcall$numerator) & !is(eval(tempcall$numerator), "formula")) stop("Invalid numerator formula specified")
-			if (!is.null(tempcall$denominator) & !is(eval(tempcall$denominator), "formula")) stop("Invalid denominator formula specified")
-			if (tempcall$family %in% c("gaussian") & !("numerator" %in% names(tempcall))) stop("Numerator necessary for family = \"gaussian\"")
-			if (!("data" %in% names(tempcall))) stop("No data specified")
-			if (!is.null(tempcall$trunc)) {if(tempcall$trunc < 0 | tempcall$trunc > 0.5) stop("Invalid truncation percentage specified (0-0.5)")}
+			# Helper function to check for required arguments
+			check_required <- function(arg, msg, arg_list = tempcall) {
+			  if (!(arg %in% names(arg_list))) stop(msg)
+			}
+
+			# Helper function to check if a value is in a set
+			check_in_set <- function(value, valid_set, msg) {
+			  if (!(value %in% valid_set)) stop(msg)
+			}
+
+			# Check required variables
+			check_required("exposure", "No exposure variable specified")
+			check_required("denominator", "No denominator model specified")
+			check_required("data", "No data specified")
+
+			# Family-specific checks
+			valid_families <- c("binomial", "multinomial", "ordinal", "gaussian")
+			valid_links <- list(
+			  binomial = c("logit", "probit", "cauchit", "log", "cloglog"),
+			  ordinal = c("logit", "probit", "cauchit", "cloglog")
+			)
+
+			check_in_set(family, valid_families, "Invalid family specified")
+			if (family %in% names(valid_links) && !(link %in% valid_links[[family]])) {
+			  stop(paste("No valid link function specified for family =", family))
+			}
+
+			# Validate numerator and denominator formulas
+			if (!is.null(tempcall$numerator)) {
+			  if (!is(eval(tempcall$numerator), "formula")) stop("Invalid numerator formula specified")
+			}
+			if (!is.null(tempcall$denominator)) {
+			  if (!is(eval(tempcall$denominator), "formula")) stop("Invalid denominator formula specified")
+			}
+
+			# Check for numerator in Gaussian family
+			if (tempcall$family == "gaussian") {
+			  check_required("numerator", "Numerator necessary for family = \"gaussian\"")
+			}
+
+			# Validate truncation percentage
+			if (!is.null(tempcall$trunc)) {
+			  if (tempcall$trunc < 0 | tempcall$trunc > 0.5) stop("Invalid truncation percentage specified (0-0.5)")
+			}
+
+		# Check if exposure is in correct format
+			data[[deparse(tempcall$exposure)]] <- check_exposure(data[[deparse(tempcall$exposure)]], family)
 		#make new dataframe for newly computed variables, to prevent variable name conflicts
 			tempdat <- data.frame(
 				exposure = data[,as.character(tempcall$exposure)]
 			)
 		#weights binomial
 			if (tempcall$family == "binomial") {
-				if(tempcall$link == "logit") lf <- binomial(link = logit)
-				if(tempcall$link == "probit") lf  <- binomial(link = probit)
-				if(tempcall$link == "cauchit") lf  <- binomial(link = cauchit)
-				if(tempcall$link == "log") lf  <- binomial(link = log)
-				if(tempcall$link == "cloglog") lf  <- binomial(link = cloglog)
+			  lf <- binomial(link = tempcall$link)
 				if (is.null(tempcall$numerator)) tempdat$w.numerator <- 1
 				else {
 					mod1 <- glm(