1 files changed, 181 insertions, 0 deletions

diff --git a/admin/survey/modules/mod_uporabnost/R/gen.usability.matrix.R b/admin/survey/modules/mod_uporabnost/R/gen.usability.matrix.R
new file mode 100644
index 0000000..a2b1465
--- /dev/null
+++ b/admin/survey/modules/mod_uporabnost/R/gen.usability.matrix.R
@@ -0,0 +1,181 @@
+gen.usability.matrix <- function(dsa, survey.str){

+  #define special values to detect

+  #order of this values is important: 

+  #  in case of conflicts @ chk.t types of questions the order sets the priporty of which values to keep

+  special.v <- c(-1, -3, -5, -96, -97, -98, -99, -4, -2)

+  

+  #define which variables belong to checkbox-like* questions

+  #(* i.e.: check for special values @ ANY variable per question/item ID)

+  # 2: normal checkbox

+  # 16: multicheckbox

+  # 17: ranking

+  chkbox.t <- c(2, 16, 17)

+  

+  ##all other variables belong to normal** questions

+  #(** i.e.: check for special values @ each variable per question/item ID)

+  #if there are no normal questions, create 0 matrix, otherwise...

+  if(nrow(survey.str[!(tip %in% chkbox.t),])==0){

+    m.n <- matrix(0, nrow = nrow(dsa), ncol=length(special.v)+1)

+  }else{

+    #create list of all normal questions

+    c.n <- colnames(dsa)[which(colnames(dsa) %in% survey.str[!(tip %in% chkbox.t), variable])]

+    

+    #...count all non-special values for each variable

+    #... + count each special value for each variable

+    m.n <- cbind(rowSums(sapply(dsa[, c.n, with=FALSE], function(x){!(x %in% special.v)})),

+                 sapply(special.v, function(x){as.integer(rowSums(dsa[, c.n, with=FALSE]==x, na.rm=TRUE))}))

+  }

+  

+  ##procedure for tip:2

+  #only run if there is an at least one tip:2 variable

+  if(survey.str[, any(tip==2)]){

+    #get list of all unique tip:2 question ids

+    q.2 <- unique(survey.str[tip==2, question.id])

+    #get list of all corresponding variables for each q.2 id

+    c.2 <- lapply(q.2, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[question.id==x & tip==2, variable])]})

+    

+    #(do this for each instance in c.2):

+    #for each set of variables:

+    # check if any variable contains at least one non-special value

+    # + (for each special value) check if any variable contains at least special value 

+    m.2 <- lapply(c.2, function(x){

+      cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}),

+            sapply(special.v, function(y){

+              apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)})

+            })

+      )

+    })

+    

+    # (do this for each instance in c.2)

+    # if multiple special values per respondent exist, keep only the first one

+    m.2 <- lapply(m.2, function(x){

+      if(any(rowSums(x)>1)){

+        p <- x[rowSums(x)>1,]

+        for(i in 1:nrow(p)){

+          a <- p[i,]

+          f <- TRUE

+          for(j in 1:length(a)){

+            print(j)

+            if(a[j] & f){

+              f <- FALSE

+            }else if(a[j] & !f){

+              a[j] <- FALSE

+            }

+          }

+          p[i,] <- a

+        }

+        x[rowSums(x)>1,] <- p

+      }else{x}

+    })

+    

+    

+    #add to m.n

+    m.n <- m.n + Reduce('+', m.2) 

+  }

+  

+  ##procedure for tip:16

+  #only run if there is an at least one tip:16 variable

+  if(survey.str[, any(tip==16)]){

+    #get list of all unique tip:16 item ids

+    q.16 <- unique(survey.str[tip==16, item.id])

+    

+    #get list of all corresponding variables for each q.16 id

+    c.16 <- lapply(q.16, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[item.id==x & tip==16, variable])]})

+    #(do this for each special value):

+    #for each set of variables, check if any variable contains at least one special value

+    # m.16 <- sapply(special.v, function(x){

+    #   rowSums(sapply(c.16, function(y){

+    #     apply(dsa[, y, with=FALSE], 1, function(q){any(q==x)})

+    #   }))

+    # })

+    

+    #(do this for each instance in c.16):

+    #for each set of variables:

+    # check if any variable contains at least one non-special value

+    # + (for each special value) check if any variable contains at least special value 

+    m.16 <- lapply(c.16, function(x){

+      cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}),

+            sapply(special.v, function(y){

+              apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)})

+            })

+      )

+    })

+    

+    # (do this for each instance in c.16)

+    # if multiple special values per respondent exist, keep only the first one

+    m.16 <- lapply(m.16, function(x){

+      if(any(rowSums(x)>1)){

+        p <- x[rowSums(x)>1,]

+        for(i in 1:nrow(p)){

+          a <- p[i,]

+          f <- TRUE

+          for(j in 1:length(a)){

+            print(j)

+            if(a[j] & f){

+              f <- FALSE

+            }else if(a[j] & !f){

+              a[j] <- FALSE

+            }

+          }

+          p[i,] <- a

+        }

+        x[rowSums(x)>1,] <- p

+      }else{x}

+    })

+    

+    m.n <- m.n + Reduce('+', m.16)

+  }

+  

+  ##procedure for tip:17

+  #only run if there is an at least one tip:17 variable

+  if(survey.str[, any(tip==17)]){

+    #get list of all unique tip:17 question ids

+    q.17 <- unique(survey.str[tip==17, question.id])

+    

+    #get list of all corresponding variables for each q.17 id

+    c.17 <- lapply(q.17, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[question.id==x & tip==17, variable])]})

+    

+    #similiar procedure as for tip:2 and tip:16....

+    m.17 <- lapply(c.17, function(x){

+      cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}),

+            sapply(special.v, function(y){

+              apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)})

+            })

+      )

+    })

+    

+    #... the only difference is that we are checking for all rowsums > 0, not > 1

+    m.17 <- lapply(m.17, function(x){

+      if(any(rowSums(x)>1)){

+        p <- x[rowSums(x)>0,]

+        for(i in 1:nrow(p)){

+          a <- p[i,]

+          f <- TRUE

+          for(j in 1:length(a)){

+            if(a[j] & f){

+              f <- FALSE

+            }else if(a[j] & !f){

+              a[j] <- FALSE

+            }

+          }

+          p[i,] <- a

+        }

+        x[rowSums(x)>0,] <- p

+      }else{x}

+    })

+    

+    m.n <- m.n + Reduce('+', m.17)

+  } 

+  

+  m.n <- cbind(m.n, rowSums(m.n))

+  

+  if(all(m.n[, ncol(m.n)][1]==m.n[, ncol(m.n)])){

+    m.n <- as.data.table(m.n)

+    m.n[, recnum:=dsa$recnum]

+    setnames(m.n, colnames(m.n)[-length(colnames(m.n))], c("va", "v1", "v3", "v5", "v96", "v97", "v98", "v99", "v4", "v2", "allqs"))

+    setcolorder(m.n, c("recnum", colnames(m.n)[-length(colnames(m.n))]))

+    return(m.n)

+  }else{

+    print("not all rowsums equal!") 

+  }

+}
\ No newline at end of file