##################################################################### # # # R Script for the publication # # # # Preference Decomposition and the # # Expressiveness of Preference Query Languages # # # # to appear in: Mathematics of Program Construction (MPC) 2015 # # # # (c) April, 3rd, 2015, Patrick Roocks # # # ##################################################################### # Content # ~~~~~~~ # # 1) rPref-based framework (Set preferences and related function) # 2) Example from the introduction # 3) Small (counter-)examples from the paper, visualizations (Section 3) # 4) Implementation and example runs of algorithms (Section 4, Section 5) # 5) Model finder (Appendix B) # # # Note that: # # Because of historical reasons, the direction of all the arrows # in the diagrams is contrary to the paper # (in rPref: better elements --> worse elements, # in the paper: worse elements --> better elements) # According to this, the succesor/predecessor functions are also swapped, # i.e. successors in the paper are better tuples, in rPref they are worse. # # This script can be run line by line and all the external dependencies # which are required from CRAN are installed in Part 1. # (Primarily the rPref package in version >= 0.5 is required) # 1) rPref-based framework for the paper # ====================================== # Installation of rPref package from CRAN (if not installed or outdated; has to be done just once) if (!("rPref" %in% rownames(installed.packages())) || packageVersion("rPref") < '0.5') { install.packages("rPref", type = "both") } # Inlucde rPref package and the igraph package for plotting preference graphs library(rPref) library(igraph) # Set preference for multiple args, t(1,2) is t(x_1+x_2) in the paper t <- function(...) { p <- true(id %in% c(...)) # Substitute "..." by the concrete id values and return return(eval.pref(p, list(id = NA))) } # Implement an r-equality check of a and b (based on the Hasse diagrams) is_r_equal <- function(a, b, r) identical(get_hasse_diag(r, a), get_hasse_diag(r, b)) # Visualization: Plot a preference on a given data set plot_pref = function(pref, df) { # from rPref: Get Hasse diagram and layout btg <- get_btg(df, pref) # Plot graph with igraph package plot(btg$graph, layout = btg$layout, vertex.label = df$id, vertex.size = 25) } # 2) Introductory Example (section 1) / Figure 1 # ============================================== df <- mtcars[21:30,] p <- high(mpg) * high(hp) # from rPref: Get Hasse diagram and "tune" the layout btg <- get_btg(df, p) layout <- btg$layout layout[2,2] <- 0 layout[3,2] <- -1 # Plot graph with igraph package plot(btg$graph, layout = layout, vertex.label = paste0(df$mpg,",\n",df$hp), vertex.size=30) # Plot pareto front and diagram of the maxima dfmax <- psel(df,p) par(mar = c(4,4,0,0)) plot(df$mpg, df$hp, lwd = 1.5) plot_front(df, p) points(dfmax$mpg, dfmax$hp, lwd = 3) # 3) Small (counter-)examples, visualizations (Section 3) # ======================================================= # Example 3.4 / Remark 3.5 / Figure 2 # ----------------------------------- # Plot all given preferences from Example 3.4 r <- data.frame(id = 1:4) # data set for the following plot_pref(t(1), r) # a plot_pref(t(1) & t(2), r) # b plot_pref(t(1) & (t(2) * t(3)), r) # c # Plot the preference d from Remark 3.5 r <- data.frame(id = 1:6) plot_pref((t(1) & (t(2) * t(3)) & t(4)) * (t(5) & t(6)), r) # Lemma 3.6 and text below / Figure 3 # ----------------------------------- # # (counterexamples falsifying equality) r <- data.frame(id = 1:3) # data set for a plot_pref((t(1) & t(2)) * t(3), r) # a r <- data.frame(id = 1:4) # data set for b, c and d plot_pref(((t(1) * t(3)) & t(2)) * (t(3) & t(4)), r) # b ("N-shaped" preference) plot_pref((t(1) * t(3)) & t(2), r) # b' plot_pref((t(1) * t(3)) & t(2) & t(4), r) # c plot_pref((t(1) * (t(3) & t(4))) & t(2), r) # d # Example 3.9 / Figure 4 # ---------------------- # Data set for a and b r <- data.frame(id = 1:5) # Construct preference "a" and alternative decomposition a <- (((t(1) & t(3)) * t(2)) & t(4)) * t(5) a_ <- t(1) * t(2) * t(1, 3) * t(1, 2, 3, 4) * t(5) # Plot preference plot_pref(a, r) # Check if a and a_ are r-equivalent is_r_equal(a, a_, r) # Construct preference "b" and alternative decomposition b <- (((t(1) * t(3)) & t(2)) * (t(3) & t(4))) & t(5) b_ <- t(1) * t(3) * t(1, 2, 3) * t(3, 4) * t(1, 2, 3, 4, 5) # Plot preference plot_pref(b, r) # Check if b and b_ are r-equivalent is_r_equal(b, b_, r) # 4) Implementation of algorithms (Section 4) # =========================================== # Helper for folding Pareto for the following algorithms reduce_pareto <- function(b) { if (length(b) == 0) return(empty()) else return(Reduce(`*`, b[-1], b[[1]])) } # Decomp_Pareto Algorithm from Theorem 4.1 # ---------------------------------------- decomp_pareto <- function(a, r) { # Assume sequential primary key "id" (according to t_(.) defintion) stopifnot(identical(r$id, 1:nrow(r))) # Init pred/succs of Hasse diagram (has to be called in rPref before (all_)pred/succ) init_pred_succ(r, a) # Compose preferences 'a$all_pred(x)' corresponds to ' r' m <- psel(r, a)$id # Initial value of array b (implemented as R list) b <- list() b[1:nrow(r)] <- empty() # Empty preference corresponds to "0" in the paper # Init pred/succs of Hasse diagram (has to be called in rPref before (all_)pred/succ) init_pred_succ(r, a) # Traverse the Hasse diagram while(length(m) > 0) { # Implementation of the for-loop in an lappy-function b[m] <- lapply(m, function(x) { b_x <- b[hasse_pred(a, x)] # Corresponds to 'b[x] with x \in r tuple decompositions # Dataset from Example 3.9 r <- data.frame(id = 1:5) # Example runs with: Preferences a, a' from Ex. 3.9 # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Transform singelton decomposition to pareto, check equality and show the preference a1 <- (((t(1) & t(3)) * t(2)) & t(4)) * t(5) a2 <- decomp_pareto(a1, r) is_r_equal(a1, a2, r) a2 # is identical to a3 (subsequent) # Transform pareto decomposition into singleton, check again and show preference a3 <- t(1) * t(2) * t(1, 3) * t(1, 2, 3, 4) * t(5) a4 <- decomp_tuple(a3, r) is_r_equal(a3, a4, r) a4 # is identical to a1 (above) # Example runs with: Preferences b, b' from Ex. 3.9, (same as pref. a in Fig. 6) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Do the same for b and Singleton->Pareto, b1 <- (((t(1) * t(3)) & t(2)) * (t(3) & t(4))) & t(5) b2 <- decomp_pareto(b1, r) is_r_equal(b1, b2, r) b2 # and for Pareto->Singleton (Example run in Figure 6) b3 <- t(1) * t(3) * t(1, 2, 3) * t(3, 4) * t(1, 2, 3, 4, 5) b4 <- decomp_tuple(b3, r) is_r_equal(b1, b4, r) b4 # Identical to Operator tree in Fig. 6(4) # Remark 4.2 / Figure 5 # --------------------- # Data set for a and b r <- data.frame(id = 1:4) # Construct a and b preferences a <- t(1) * t(2) * t(1, 3) * t(1, 2, 3, 4) b <- t(1, 2) * t(1, 3) * t(1, 2, 3, 4) # Show that a and b are NOT r-equivalent is_r_equal(a, b, r) # Plot preferences to see the difference plot_pref(a, r) plot_pref(b, r) # Section 5.2 (Minimal decompositions) # ------------------------------------ # Data set r <- data.frame(id = 1:4) # Show the blow-up of 0 for tuple decomposition decomp_tuple(empty(), r) # Show the blow-up of 0 for pareto decomposition decomp_pareto(empty(), r) # decomp_tuple of the layered preference mentioned in this section a <- t(1, 2) & t(3, 4) plot_pref(a, r) b <- decomp_tuple(a, r) b # Simpler alternative to b b2 <- (t(1) * t(2)) is_r_equal(b, b2, r) # 5) Model finder (Appendix B) # ============================ # Show that for the preference # # ((t(1) * t(3)) & t(2)) * (t(3) & t(4)) # # there is no decomposition into unique tuple preferences # # (which is not unique as t(3) occurs twice) # Data set and the preference to decompose (a_ref) r <- data.frame(id = 1:4) a_ref <- ((t(1) * t(3)) & t(2)) * (t(3) & t(4)) # Recursive search for unique tuple decompositions search <- function(a_tmp, xs) { # Check if temporary pref is equivalent to the reference if (is_r_equal(a_tmp, a_ref, r)) return(TRUE) # Recursively search for other possible terms if (length(xs) > 0) { for (x in xs) { if (search(a_tmp & t(x), setdiff(xs, x))) return(TRUE) if (search(a_tmp * t(x), setdiff(xs, x))) return(TRUE) } } return(FALSE) } # Start search (returns FALSE) search(empty(), 1:4)