---
title: "Binary Regression"
author: "Ramin Mojab"
date: "`r Sys.Date()`"
output: rmarkdown::html_vignette
vignette: >
  %\VignetteIndexEntry{Binary Regression}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "  >"
)
```

```{r}
library(ldt) 

seed <- 123
set.seed(seed)
```


## Introduction
In this vignette, I will introduce you to the `ldt` package and its main features for dealing with Logistic and Probit Regression models. You will learn how to estimate a binary model, make predictions, and assess model uncertainty. Additionally, we will explore the use of Principal Component Analysis as an alternative approach for handling a large number of potential explanatory variables.

One of the key ideas behind `ldt` is to minimize user discretion by using a rule-based approach to select data. This approach not only avoids discretion but also automates the process of searching for the best models within a defined model set.

To demonstrate these features, I will create an artificial dataset with a dependent variable and both relevant and irrelevant explanatory variables. The dependent and relevant explanatory variables are sampled from a known binary model. While we can evaluate how well the estimation process finds the true parameters, our main focus will be on how to estimate, search, predict, and report results.

Let’s get started!



## A simple experiment
Let’s start by assuming that we know the structure of the model. We can do this by simulating data from two known binary models. The following command generates the required samples:

```{r}
num_obs <- 100
num_exo <- 4L 
p_positive <- 0.4
max_weight <- 2
sample_l <- sim.bin(num_exo, num_obs, probit = FALSE, pPos = p_positive, maxWeight = max_weight)
sample_p <- sim.bin(sample_l$coef, num_obs, probit = TRUE, pPos = p_positive, maxWeight = max_weight)
 
print(sample_l$coef)
```

We know the parameters of the systems because they are included in the output of the `sim.bin` function. Note that there is a logit and a probit model. Each model has one equation or dependent variable. This equation has an intercept and `r num_exo-1` exogenous variables. The sample size is `r num_obs`. The coefficient vector of the logit model is generated randomly and is listed in the output, `sample_l`. It is used to sample data from the logit model and therefore, the parameters of the two models are the same. In these samples, `r p_positive*100` percent of observations are labeled as positive (because of `pPos` argument). Finally, since `max_weight` is larger than 1, observations are weighted and there is a w element in the returned lists that we should consider in the estimation process.

The LaTeX code for the equation of the two models is included in the `eqLatex` elements of the output. It results in the following representations:

Logit: \begin{aligned} `r sample_l$eqLatex` \end{aligned} 

Probit: \begin{aligned} `r sample_p$eqLatex` \end{aligned}

Remember that these are the parameters of the system. We can use the `glm` function to estimate them. The following code shows how to do this. In the first line we prepare the equations and then we fit two models for our two samples:

```{r}
eq_str <- paste0("Y ~ ", paste0(colnames(sample_l$x[,-1]), collapse = " + "))

fit_l <- glm(eq_str, data = data.frame(sample_l$y, sample_l$x), 
             family = binomial(link = "logit"), weights = sample_l$w) 
fit_p <- glm(eq_str, data = data.frame(sample_p$y, sample_p$x), 
             family = binomial(link = "probit"), weights = sample_l$w) 
 
fit_sf_l <- sim.bin(fit_l$coefficients, probit = FALSE )
fit_sf_p <- sim.bin(fit_p$coefficients, probit = TRUE)
```

The last two lines are used for reporting the LaTeX formula. We use eqLatex element of the output and this is the result:

Logit: \begin{aligned} `r fit_sf_l$eqLatex` \end{aligned} 

Probit: \begin{aligned} `r fit_sf_p$eqLatex` \end{aligned}

Note that these representations are not very appropriate for an estimated model because they do not report the estimated standard errors and there are better ways to do so. However, it suits our purpose here. Also, note that you can get better results (in terms of lower difference between actual and estimated coefficients) by increasing the sample size.

The following code does the same by using the `estim.bin` function in the `ldt` package:

```{r}
fit_l <- estim.bin(sample_l$y, sample_l$x[,-1], sample_l$w) 

fit_p <- estim.bin(sample_p$y, sample_p$x[,-1], sample_p$w, linkFunc = "probit") 

res_table <- coefs.table(list(Logit = fit_l, Probit = fit_p), 
                             regInfo = c("obs"), formatLatex = FALSE)
```

The last line converts the estimated result into a table for presentation. Additional arguments can be used to control the format and level of information displayed in the table. The `kable` function can be used to report the contents of the table. This is the result:

```{r echo=FALSE}
kableExtra::kable(res_table, "html", escape = FALSE, table.attr = "style='width:50%;border-bottom: 1px solid;'",
                  caption = "Results of estimation using `ldt::estim.bin` function.")
```

Differences between the results of `systemfit` and `estim.bin` functions may be due to variations in initialization or optimization procedures.

While the `coefs.plot` function was discussed in [another vignette on SUR models](sur.html), this vignette focuses on prediction rather than parameter estimation. As such, it will not be covered here.

## Prediction
A binary regression model can be used in binary classification practices. It involves using the model to predict the likelihood that a new case will fall into one of two classes based on the values of the explanatory variables. The class is either positive ($Y = 1$) or negative ($Y = 0$). The regression model estimates the likelihood given the explanatory variables, i.e., $P(Y=1∣X)$. We can calculate the other probability: $P(Y=0∣X)=1−P(Y=1∣X)$. Deciding the class of the observation given the probability need a decision rule.

To continue our experiment, let’s focus on the logit model and generate a sample of size 10 from the true model using the `sim.bin` function. We can predict using the `estim.bin` function in `ldt` by setting the `newX` argument. This is the code:

```{r}
sample_l_new <- sim.bin(sample_l$coef, 10, probit = FALSE)

fit_l <- estim.bin(sample_l$y, sample_l$x[,-1], sample_l$w, newX = sample_l_new$x[,-1])
```

We have three types of information: the actual class of the observation (`sample_l$y`), the probabilities used in the simulation process (`sample_l$p1`), and the predicted probabilities `fit_l$projection[,2]`. Let’s plot them:


```{r echo=FALSE}
actual_classes <- as.numeric(sample_l_new$y)
probabilities <- as.numeric(sample_l_new$p1)
predictions <- as.numeric(fit_l$projection[,2])
barplot(actual_classes, col = "lightblue", ylim = c(0, 1), ylab = "Class / Probability") 
points(seq_along(probabilities), probabilities, col = "green", pch = 19) 
points(seq_along(predictions), predictions, col = "red", pch = 3) 
par(xpd=TRUE)
legend(x=0,y=1.5, legend = c("Actual Class", "Probability", "Prediction"), fill = c("lightblue", NA, NA),
       pch = c(NA, 19, 3), bg="transparent", bty = "n",
       col=c("lightblue" ,"green", "red"), border=c(NA, NA, NA))
```

As you can see, it’s possible to have positive observations with low probabilities and negative observations with high probabilities due to the random nature of the binomial distribution. 

In practice, we do not see the green circles, i.e., $P(Y=1∣X)$. We only see the actual class of observations. The binary regression model predicts the green circles. This means that even if we have the exact coefficient vector, the best we can do is to predict the exact probability and not the actual class of observation. There must be a decision-making process that converts the predicted probability to a specific class.

When using a binary regression model to make classification decisions, a common approach is to define a threshold value for the predicted probability. If the predicted probability for a case is greater than or equal to the threshold value, the case is classified as belonging to the positive class. If the predicted probability is less than the threshold value, the case is classified as belonging to the negative class.

However, threshold is not a parameter of the model but just a decision rule. The choice of threshold value can affect the balance between sensitivity and specificity but cannot completely eliminate classification error. One might design a more complex decision-making process than using just one fixed threshold level.
There are several ways to evaluate the predictive power of a binary regression model. One common approach is to use a confusion matrix to calculate accuracy, sensitivity, specificity, and precision. Other metrics include AUC-ROC and Brier score. The AUC-ROC represents the probability that a randomly chosen positive case will have a higher predicted probability than a randomly chosen negative case. A lower Brier score indicates better predictive performance.
 
Similar to the previous subsection, we can use `coefs.table` function and report the results in a table:

```{r}
res_table <- coefs.table(list(Logit = fit_l), 
                             regInfo = c("obs", "aic", "sic", "aucIn", "brierIn"), 
                             formatLatex = FALSE)
```
```{r echo=FALSE}

kableExtra::kable(res_table, "html", escape = FALSE, table.attr = "style='width:50%;border-bottom: 1px solid;'",
                  caption = "Results of estimation using `ldt::estim.bin` function with prediction.")
```
 
One metric (specific to our experiment) is not present in the table. Its formula is $a = \frac{\sum_{i=1}^{n}(p_i-\hat{p}_i)^2}{n}$ where $p_i$ represents the actual probabilities (the green circles in the plot) and $\hat{p}_i$ represents the predicted probabilities (the red plus signs in the plot). This metric is similar to the Brier score but uses actual probabilities. A value of zero indicates a perfect fit and larger values indicate lower explanatory power. The value for this experiment is `r sum((probabilities-predictions)^2)/length(probabilities)`.


## Model uncertainty
Let’s consider a more realistic situation where model uncertainty exists. That’s where `ldt` can help. In the previous subsection, we knew all relevant explanatory variables. Here, we consider a situation where there are some irrelevant variables too. We limit the level of uncertainty and other practical issues by restricting the number of these variables. The following code reflects our assumptions:

```{r}
sample_l$x <- cbind(sample_l$x, matrix(rnorm(num_obs * 50), ncol = 50, 
                                   dimnames = list(NULL,paste0("z",1:50))))

sample_l_new$x <- cbind(sample_l_new$x, matrix(rnorm(nrow(sample_l_new$x) * 50), ncol = 50, 
                                   dimnames = list(NULL,paste0("z",1:50))))
```

In our experiment, there are `r ncol(sample_l$x)-num_exo` irrelevant and `r num_exo-1` relevant variables. The number of irrelevant data is relatively large and their names start with the `z` character. The second line of code creates out-of-sample data in the extended sample for use in prediction.

The following code uses the `search.bin` function to find the actual model:

```{r eval=FALSE, include=TRUE}
search_res <- search.bin(sample_l$y, sample_l$x[,-1], sample_l$w,
                        xSizes = c(1:5), 
                        metricOptions = get.options.metric(typesIn = c("sic")))
```

The `xSizes = c(1:4)` part assumes that we know the number of relevant explanatory variables is less than 5. The `metric_options` part shows that we use SIC metrics to evaluate and compare models.

This code is time-consuming and is not evaluated here. However, on my system, the elapsed time is 77 seconds (the number of searched models is 317682). Note that if we change our previous guess and assume that the maximum number of relevant variables is larger, for example 5, the size of the practical model set becomes 3187367 (10 times larger) and this is estimated in 977 seconds (12 times larger) on my system. Many factors affect this time, including optimization process options. Also check the parallel option in `get.options.search()` function. 

One might reduce the number of potential explanatory variables using theory or statistical testing. Since `ldt` dislikes user discretion, it provides a more systematic approach. The idea behind it is simple: estimate smaller models, select variables, estimate larger models with fewer potential explanatory variables. Here is the code:

```{r}
x_size_steps = list(c(1, 2), c(3), c(4), c(5))
count_steps = c(NA, 20, 10, 9)

search_step_res <-
  search.bin.stepwise(y = sample_l$y, x = sample_l$x, w = sample_l$w,
                      xSizeSteps = x_size_steps, countSteps = count_steps,
                      metricOptions = get.options.metric(typesIn = c("aic","sic", "auc", "brier")),
                      searchItems = get.items.search(bestK = 10))
search_step_res
```

The first two lines define the steps. We use all variables (`NA` in `count_steps` means all) to estimate models with sizes defined as the first element of `x_size_steps`. Then we select a number of variables from the information provided by the best models and estimate models with sizes determined by the second element of `x_size_steps`. And so on.

The size of the model subset and running time are greatly reduced. However, let’s see its performance.

To study or report results, we should use the `summary` function. The output of a search project in `ldt` does not contain estimation results but only the minimum level of information to replicate them. The `summary` function does the job and estimates the models. Here is the code:

```{r}
ssum <- summary(search_step_res, 
                y = sample_l$y, x = sample_l$x, w = sample_l$w, 
                newX = sample_l_new$x, 
                printMsg = FALSE)
```

Usually, there is more than one model in the `summary` output. This is because the output is first “target-variable-specific” and second “evaluation-specific”. In this application, there is just one target but we requested four different types of evaluations in the get.options.metric function. We can report the results by creating a list of estimated models and using the coefs.table function:

```{r}
mod_list <- list("SIC" = ssum$sic$target1$model$bests$best1,
                 "AIC" = ssum$aic$target1$model$bests$best1,
                 "AUC" = ssum$aucIn$target1$model$bests$best1,
                 "Brier" = ssum$brierIn$target1$model$bests$best1)
res_table <- coefs.table(mod_list, 
                             regInfo = c("obs", "aic", "sic", "aucIn", "brierIn"), 
                             formatLatex = FALSE)
```

Since we set the `newX` argument in the `summary` function, we can plot the predictions:


```{r echo=FALSE}
actual_classes <- as.numeric(sample_l_new$y)
probabilities <- as.numeric(sample_l_new$p1)

predictions_sic <- as.numeric(mod_list$SIC$projection[,2])
predictions_aic <- as.numeric(mod_list$AIC$projection[,2])
predictions_auc <- as.numeric(mod_list$AUC$projection[,2])
predictions_bri <- as.numeric(mod_list$Brier$projection[,2])

barplot(actual_classes, col = "lightblue", ylim = c(0, 1), ylab = "Class / Probability") 
points(seq_along(probabilities), probabilities, col = "green", pch = 19) 

points(seq_along(predictions_sic), predictions_sic, col = "red", pch = 3) 
points(seq_along(predictions_aic), predictions_aic, col = "pink", pch = 4) 
points(seq_along(predictions_auc), predictions_auc, col = "orange", pch = 5) 
points(seq_along(predictions_bri), predictions_bri, col = "brown", pch = 6) 

par(xpd=TRUE)
legend(x=0,y=1.5, legend = c("Actual Class", "Probability", "p: SIC", "p: AIC", "p: AUC", "p: Brier"), fill = c("lightblue", NA, NA, NA, NA, NA),
       pch = c(NA, 19, 3, 4, 5, 6), bg="transparent", bty = "n",
       col=c("lightblue" ,"green", "red", "pink", "orange", "brown"), border=c(NA, NA, NA,NA, NA, NA))
```


With current seed and other options, all metrics point to a common model. In this regression model a relevant variable (`X3`) is missing and three irrelevant variables are present with non-significant coefficients.

 

## Out-of-sample simulation

Let’s see if we can do any better by using out-of-sample evaluations. The following code is similar to the code in the previous section, but we define a out-of-sample process:

```{r}
metric_options <- get.options.metric(typesOut = c("auc", "brier"), 
                                       seed = -seed, simFixSize = 5, trainRatio = 0.75)
search_step_res <-
  search.bin.stepwise(y = sample_l$y, x = sample_l$x, w = sample_l$w,
                      xSizeSteps = x_size_steps, countSteps = count_steps,
                      metricOptions = metric_options,
                      searchItems = get.items.search(bestK = 10),
                      searchOptions = get.options.search(printMsg = FALSE))
search_step_res
```

We use `r metric_options$trainRatio` ratio of the observations (determined by `trainRatio`) for estimating and the rest for testing. We repeat this experiment `r metric_options$simFixSize` times (determined by `simFixSize`). We can report the result similar to the previous discussion:

```{r echo=FALSE}
ssum <- summary(search_step_res, 
                y = sample_l$y, x = sample_l$x, w = sample_l$w, 
                newX = sample_l_new$x, 
                printMsg = FALSE)
mod_list <- list("AUC" = ssum$aucOut$target1$model$bests$best1,
                 "Brier" = ssum$brierOut$target1$model$bests$best1)
res_table <- coefs.table(mod_list, 
                             regInfo = c("obs", "aucOut", "brierOut"), 
                             formatLatex = FALSE)
```

You can get better results by increasing the number of observations. Also, you can change optimization algorithm options or other search options to improve performance.






