update-vignette

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: gosset
 Type: Package
 Title: Tools for Data Analysis in Experimental Agriculture
-Version: 1.4
+Version: 1.4.1
 Authors@R: c(person("Kauê", "de Sousa", 
         email = "desousa.kaue@gmail.com", role = c("aut", "cre"),
         comment = c(ORCID = "0000-0002-7571-7845")),

R/worth_map.R

@@ -8,6 +8,8 @@
 #'  an object of class \code{PlackettLuce} or
 #'  a list objects of class \code{PlackettLuce}
 #' @param labels a vector with the name of models in \var{object}
+#' @param labels.order optional, a vector to determine the order of labels
+#' @param items.order optional, a vector to determine the order of items
 #' @param ... additional arguments passed to methods
 #' @examples 
 #' library("psychotree")
@@ -106,20 +108,41 @@ worth_map.default = function(object, ...) {
 #' @method worth_map list
 #' @rdname worth_map
 #' @export
-worth_map.list = function(object, labels, ...) {
+worth_map.list = function(object, 
+                          labels, 
+                          labels.order = NULL, 
+                          items.order = NULL, ...) {
+
+  if (is.null(labels.order)) {
+    lvls = labels
+  } else {
+    lvls = labels.order
+  }
 
-  winprobs = .combine_coeffs(object, log = TRUE, vcov = FALSE, ...)
+  winprobs = .combine_coeffs(object, log = TRUE, ...)
 
   # add name of features
   names(winprobs) = labels
 
+  if (is.null(items.order)) {
+    order_items = order(exp(winprobs[,lvls[[1]]]))
+    order_items = rownames(winprobs)[order_items]
+  } else {
+    order_items = items.order
+  }
+
+
+
   winprobs = data.frame(items = rep(dimnames(winprobs)[[1]], 
                                     times = ncol(winprobs)),
                         labels = rep(dimnames(winprobs)[[2]], 
                                      each = nrow(winprobs)),
                         winprob = as.numeric(unlist(winprobs)))
 
-  winprobs$labels = factor(winprobs$labels, levels = labels)
+  winprobs$labels = factor(winprobs$labels, levels = rev(lvls))
+
+  winprobs$items = factor(winprobs$items, 
+                          levels = rev(order_items))
 
   items = winprobs$items
   winprob = winprobs$winprob
@@ -142,16 +165,13 @@ worth_map.list = function(object, labels, ...) {
                                   direction = 1,
                                   na.value = "white",
                                   name = "") +
-    ggplot2::theme_bw() +
-    theme(axis.text = ggplot2::element_text(color = "grey20"),
-          strip.text.x = ggplot2::element_text(color = "grey20"),
-          axis.text.x = ggplot2::element_text(angle = 40, vjust = 1, hjust = 1),
-          axis.text.y = ggplot2::element_text(angle = angle, vjust = 1, hjust = 1),
-          panel.grid = ggplot2::element_blank())
-  ggplot2::labs(x = "", 
-                y = "",
-                fill = "")
-
+    ggplot2::theme_minimal() +
+    ggplot2::theme(axis.text = ggplot2::element_text(color = "grey20"),
+                   strip.text.x = ggplot2::element_text(color = "grey20"),
+                   axis.text.x = ggplot2::element_text(angle = 40, vjust = 1, hjust = 1),
+                   axis.text.y = ggplot2::element_text(angle = angle, vjust = 1, hjust = 1),
+                   panel.grid = ggplot2::element_blank()) +
+    ggplot2::labs(x = "", y = "")
 
 
   return(p)
@@ -162,11 +182,14 @@ worth_map.list = function(object, labels, ...) {
 #'Combine coefficients from PlackettLuce models
 #' @param x a list with PlackettLuce models
 #' @param na.replace logical, to replace or keep NAs
-#' @param ... further arguments passed to methods
+#' @param ... additional arguments passed to methods
 #' @noRd
 .combine_coeffs = function(x, na.replace = TRUE, rescale = TRUE, ...) {
 
-  coeffs = lapply(x, function(y) {psychotools::itempar(y, ...)})
+  coeffs = lapply(x, function(y) {
+    #psychotools::itempar(y, ...)
+    stats::coefficients(y, ...)
+  })
 
   items = unique(unlist(lapply(coeffs, names)))
 

dev/dominance-analysis.R

@@ -0,0 +1,82 @@
+library(dominanceanalysis)
+library(caTools)
+library("gosset")
+library("ClimMobTools")
+library("PlackettLuce")
+library("ggplot2")
+library("patchwork")
+
+data("cassava", package = "gosset")
+
+dat = cassava
+
+head(dat[, 1:11])
+
+keep = unlist(lapply(dat[1:ncol(dat)], function(x) sum(is.na(x))))
+
+keep = keep == 0
+
+dat = dat[, keep]
+
+names(dat)
+
+# extract list of traits from the data
+trait_list = getTraitList(dat, pattern = c("_pos", "_neg"))
+
+# trait names extracted from the function 
+traits = unlist(lapply(trait_list, function(x) x$trait_label))
+
+# clean trait names and put them title case
+traits = gsub("(^|[[:space:]])([[:alpha:]])", "\\1\\U\\2", traits, perl = TRUE)
+
+traits
+
+pack = c("option_a", "option_b", "option_c")
+
+items = sort(unique(unlist(dat[pack])))
+
+check = "Obasanjo-2"
+
+ov = which(traits %in% "Overall")
+
+R = lapply(trait_list, function(x) {
+  rank_tricot(dat, 
+              items = pack, 
+              input = x$string,
+              validate.rankings = TRUE)
+})
+
+mod = lapply(R, PlackettLuce)
+
+worth = lapply(mod, function(x){
+  z = resample(x, log = TRUE, bootstrap = TRUE, n1 = 10, seed = 1432)$estimate
+  #log(z)
+})
+
+worth = as.data.frame(do.call("cbind", worth))
+
+names(worth) = traits
+
+head(worth)
+
+plot(worth$Colour, worth$Overall)
+plot(worth$Stretchability, worth$Overall)
+plot(worth$Taste, worth$Overall)
+
+modpres = lm(Overall ~ Taste + Stretchability + Colour, data = worth)
+
+summary(modpres)
+
+dapres = dominanceAnalysis(modpres)
+
+getFits(dapres,"r2")
+
+dominanceMatrix(dapres, type="complete",fit.functions = "r2", ordered=TRUE)
+
+contributionByLevel(dapres,fit.functions="r2")
+
+plot(dapres, which.graph ="conditional",fit.function = "r2") + theme_minimal()
+
+dom = averageContribution(dapres,fit.functions = "r2")
+
+