unif2cat

R/DataGeneration.R

@@ -110,7 +110,7 @@ DataGeneration <- function(seed=1, N=2000,
                            a_l=0.8, a_u=2.5,
                            b_m=NULL, b_sd=NULL,
                            c_l=0, c_u=0.2, categ=5,
-                           possible_ans = seq(.1,.9,length=5)){
+                           possible_ans = c(.1,.3,.5,.7,.9)){
   initialitem_D=NULL; data_D=NULL
   initialitem_P=NULL; data_P=NULL
   initialitem_C=NULL; data_C=NULL
@@ -306,10 +306,14 @@ DataGeneration <- function(seed=1, N=2000,
       # item responses
       # possible_ans <- seq(0.05,.95,length=10)#c(.1, .3, .5, .7, .9)
 
+      if(length(possible_ans) == 1){
+        possible_ans <- logit_inv(logistic_means(possible_ans))
+      }
+
       for(i in 1:nitem_C){
         for(j in 1:N){
           p <- P(theta = theta[j], a = item_C[i,1], b = item_C[i,2])
-          data_C[j,i] <- possible_ans[which.min(abs(rbeta(1, p*item_C[i,3], (1-p)*item_C[i,3]) - possible_ans))]
+          data_C[j,i] <- unif2cat(rbeta(1, p*item_C[i,3], (1-p)*item_C[i,3]), labels = possible_ans)
         }
       }
     }
@@ -325,10 +329,14 @@ DataGeneration <- function(seed=1, N=2000,
       # item responses
       # possible_ans <- seq(0.05,.95,length=10)#c(.1, .3, .5, .7, .9)
 
+      if(length(possible_ans) == 1){
+        possible_ans <- logit_inv(logistic_means(possible_ans))
+      }
+
       for(i in 1:nitem_C){
         for(j in 1:N){
           p <- P(theta = theta[j], a = item_C[i,1], b = item_C[i,2])
-          data_C[j,i] <- possible_ans[which.min(abs(rbeta(1, p*item_C[i,3], (1-p)*item_C[i,3]) - possible_ans))]
+          data_C[j,i] <- unif2cat(rbeta(1, p*item_C[i,3], (1-p)*item_C[i,3]), labels = possible_ans)
         }
       }
     }

R/non_exporting_functions.R

@@ -1471,3 +1471,50 @@ DC.LL <- function (phi, theta, freq) {
 DC.grad <- function (phi, theta, freq) {
   -freq%*%dcurver::dc_grad(theta, phi)
 }
+
+#################################################################################################################
+# Uniform to categorical values
+#################################################################################################################
+yyy <- function(x){
+  y <- exp(x)/(1+exp(x))^2
+  return(y/sum(y))
+}
+
+logistic_means <- function(x){
+  cuts <- 1/x*1:(x-1)
+  cuts <- c(1e-15, cuts, (1-1e-15))
+  cuts <- log(cuts/(1-cuts))
+
+  means <- NULL
+  for(i in 1:x){
+    xxx <- seq(cuts[i],cuts[i+1],0.0001)
+    means <- append(
+      means,
+      sum(xxx * yyy(xxx))
+    )
+  }
+  return(means)
+}
+
+logit_inv <- function(x)exp(x)/(1+exp(x))
+
+unif2cat <- function(data, labels = NULL, x = 5){
+  if(is.null(labels)){
+    cuts <- 1/x*(1:(x-1))
+    cuts <- log(cuts/(1-cuts))
+    breaks <- c(-Inf, cuts, Inf)
+    labels <- logit_inv(logistic_means(x))
+    cut_data <- cut(log(data/(1-data)), breaks = breaks, labels = FALSE)
+    return(labels[cut_data])
+  } else {
+    if(length(data) == 1){
+      return(labels[which.min(abs(data - labels))])
+    } else {
+      cuts <- 1/x*(1:x)
+      cuts <- cuts - (cuts[2]-cuts[1])/2
+      labss <- apply(abs(outer(data, cuts, FUN = "-")), MARGIN = 1, FUN = which.min)
+      return(cuts[labss])
+    }
+  }
+}
+