diff --git a/.Rbuildignore b/.Rbuildignore index 112ad26..3912071 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,3 @@ ^.*\.Rproj$ ^\.Rproj\.user$ -^\.travis\.yml$ +^\.github$ diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..2d19fc7 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..74d8c97 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,49 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true diff --git a/.gitignore b/.gitignore index 728e389..75930f7 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ .Rhistory .RData .DS_Store +inst/doc diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 23bfd62..0000000 --- a/.travis.yml +++ /dev/null @@ -1,52 +0,0 @@ -# Sample .travis.yml for R projects - -language: r -warnings_are_errors: true -sudo: true -dist: trusty - -env: - global: - - CRAN: http://cran.rstudio.com - -notifications: - email: - on_success: change - on_failure: change - -r_binary_packages: - - testthat - - devtools - -before_install: - - curl -OL http://raw.github.com/craigcitro/r-travis/master/scripts/travis-tool.sh - - chmod 755 ./travis-tool.sh - - ./travis-tool.sh bootstrap - -install: - ## For installing all CRAN dependencies using DESCRIPTION - - ./travis-tool.sh install_deps - - ## For installing all Bioconductor dependencies using DESCRIPTION - - ./travis-tool.sh install_bioc_deps - -# ## Install Github packages -# - ./travis-tool.sh install_github jimhester/covr - -env: - global: - - BIOC_USE_DEVEL="FALSE" ## Use the current release version - - R_BUILD_ARGS="--no-build-vignettes --no-manual" - - R_CHECK_ARGS="--no-build-vignettes --no-manual --timings" ## do not build vignettes or manual - - _R_CHECK_TIMINGS_="0" ## get the timing information for the examples for all of your functions - -script: - - travis_wait ./travis-tool.sh run_tests - -after_failure: - - ./travis-tool.sh dump_logs - -## Check how much time was spent in each of the example pages -after_script: - - ./travis-tool.sh dump_logs_by_extension "timings" - - ./travis-tool.sh dump_sysinfo diff --git a/DESCRIPTION b/DESCRIPTION index b58a53a..48a89fc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,15 +15,17 @@ Depends: Imports: ggplot2, gridExtra, - plyr, utils, stats, methods, grDevices, - scales + scales, + rlang, + vctrs License: MIT + file LICENSE -LazyData: true VignetteBuilder: knitr Suggests: - knitr -RoxygenNote: 7.0.2 + knitr, + rmarkdown +RoxygenNote: 7.2.3 +Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index 0a3bcf2..5000c52 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,9 +13,14 @@ import(ggplot2) import(grDevices) import(gridExtra) import(methods) -import(scales) import(stats) import(utils) +importFrom(ggplot2,aes) +importFrom(ggplot2,element_blank) +importFrom(ggplot2,element_text) +importFrom(ggplot2,geom_histogram) +importFrom(ggplot2,ggplot) +importFrom(ggplot2,theme) importFrom(grid,gpar) importFrom(grid,grid.draw) importFrom(grid,grid.layout) @@ -24,4 +29,5 @@ importFrom(grid,legendGrob) importFrom(grid,popViewport) importFrom(grid,pushViewport) importFrom(grid,viewport) -importFrom(plyr,count) +importFrom(rlang,"%||%") +importFrom(rlang,.data) diff --git a/NEWS b/NEWS index 4d8b481..9be3bcd 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,6 @@ +- Fix some warnings from ggplot2 3.0.0. +- Remove dependency on plyr + Release v1.4.0 - Allow custom y-axis label and scale diff --git a/R/Boxplot.R b/R/Boxplot.R index 3939e25..857816e 100644 --- a/R/Boxplot.R +++ b/R/Boxplot.R @@ -51,7 +51,7 @@ BoxPlotsPlot <- function(bdat, att, att_color){ panel.grid.minor = element_blank(), panel.grid.major = element_blank(), axis.title.x = element_blank()) - + geom_boxplot(data = bdat, aes_string(x="x", y="attribute"), + + geom_boxplot(data = bdat, aes(x = .data$x, y = .data$attribute), fill = att_color, colour = "gray80")) return(boxplots) } \ No newline at end of file diff --git a/R/Custom.plots.R b/R/Custom.plots.R index 9cc96c6..254a757 100644 --- a/R/Custom.plots.R +++ b/R/Custom.plots.R @@ -11,10 +11,10 @@ GenerateCustomPlots <- function(attribute_plots, Set_data, QueryData, att_color, if(length(QueryData) != 0){SetAndQueryData[1:nrow(Set_data), ]$color <- "gray23"} # x_att <- attribute_plots$plots[[i]]$x # y_att <- attribute_plots$plots[[i]]$y - if(isTRUE(attribute_plots$plots[[i]]$queries) == T){ + if(isTRUE(attribute_plots$plots[[i]]$queries)){ if(length(QueryData) == 0){ warning("To overlay with query data please specify att.x and att.y where applicable.") - if(is.null(attribute_plots$plots[[i]]$y) == F){ + if(!is.null(attribute_plots$plots[[i]]$y)){ CustomPlot[[i]] <- attribute_plots$plots[[i]]$plot(Set_data, attribute_plots$plots[[i]]$x, attribute_plots$plots[[i]]$y) } else{ @@ -22,8 +22,8 @@ GenerateCustomPlots <- function(attribute_plots, Set_data, QueryData, att_color, } } else if(length(QueryData) != 0){ - if(is.null(attribute_plots$plots[[i]]$y) == F){ - if(is.na(atty[i]) == T){ + if(!is.null(attribute_plots$plots[[i]]$y)){ + if(is.na(atty[i])){ warning("No y attribute provided to overlay with query data. If attempting to display plot that needs both x and y aesthetics please enter att.y parameter. Plots that require just the x aestheitc will not be affected.") @@ -39,7 +39,7 @@ GenerateCustomPlots <- function(attribute_plots, Set_data, QueryData, att_color, } } else { - if(is.null(attribute_plots$plots[[i]]$y) == F){ + if(!is.null(attribute_plots$plots[[i]]$y)){ CustomPlot[[i]] <- attribute_plots$plots[[i]]$plot(Set_data, attribute_plots$plots[[i]]$x, attribute_plots$plots[[i]]$y) } else{ diff --git a/R/Custom.user.queries.R b/R/Custom.user.queries.R index 3cff55b..c9d75d3 100644 --- a/R/Custom.user.queries.R +++ b/R/Custom.user.queries.R @@ -27,16 +27,16 @@ customQueriesBar <- function(cust_data, sets,bar_data,custom){ return(NULL) } for(i in 1:length(cust_data)){ - cust_data[[i]] <- count(cust_data[[i]][sets]) + cust_data[[i]] <- count_compat(cust_data[[i]][sets]) colnames(cust_data[[i]])[num] <- "freq2" cust_data[[i]] <- cust_data[[i]][!(rowSums(cust_data[[i]][ ,1:length(sets)]) == 0), ] setup[[i]] <- merge(cust_data[[i]], bar_data, by = sets) color2 <- rep(custom[[i]]$color, times = nrow(setup[[i]])) - if(isTRUE(custom[[i]]$active) == T){ - act <- rep(T, nrow(setup[[i]])) + if(isTRUE(custom[[i]]$active)){ + act <- rep(TRUE, nrow(setup[[i]])) } else{ - act <- rep(F, nrow(setup[[i]])) + act <- rep(FALSE, nrow(setup[[i]])) } setup[[i]] <- cbind(setup[[i]], color2, act) } diff --git a/R/Element.queries.R b/R/Element.queries.R index 46222ac..2123672 100644 --- a/R/Element.queries.R +++ b/R/Element.queries.R @@ -13,17 +13,17 @@ QuerieElemAtt <- function(q, data, start_col, exp, names, att_x, att_y, palette) if(length(q) == 0){ return(NULL) } - for(i in 1:length(q)){ + for(i in seq_along(q)){ index_q <- unlist(q[[i]]$params) elem_color <- unlist(q[[i]]$color) test <- as.character(index_q[1]) check <- match(test, names) if(length(check) != 0){ - if(is.na(att_y[i]) == F){ + if(!is.na(att_y[i])){ elems <- GetElements(data, index_q) end_col <- ((start_col + as.integer(length(names))) - 1) elems <- elems[which(rowSums(elems[ ,start_col:end_col]) != 0), ] - if(is.null(exp) == F){ + if(!is.null(exp)){ elems <- Subset_att(elems, exp) } if(nrow(elems) != 0){ @@ -33,11 +33,11 @@ QuerieElemAtt <- function(q, data, start_col, exp, names, att_x, att_y, palette) elems <- NULL } } - else if(is.na(att_y[i]) == T){ + else if(is.na(att_y[i])){ elems <- GetElements(data, index_q) end_col <- ((start_col + as.integer(length(names))) - 1) elems <- elems[which(rowSums(elems[ ,start_col:end_col]) != 0), ] - if(is.null(exp) == F){ + if(!is.null(exp)){ elems <- Subset_att(elems, exp) } if(nrow(elems) != 0){ @@ -65,20 +65,20 @@ QuerieElemAtt <- function(q, data, start_col, exp, names, att_x, att_y, palette) ElemBarDat <- function(q, data1, first_col, exp, names, palette, mbdata){ - data1 <- data.frame(data1, check.names = F) - bar <- count(data1) + data1 <- data.frame(data1, check.names = FALSE) + bar <- count_compat(data1) bar$x <- 1:nrow(bar) rows <- data.frame() act <- c() if(length(q) == 0){ return(NULL) } - for(i in 1:length(q)){ + for(i in seq_along(q)){ index_q <- unlist(q[[i]]$params) test <- as.character(index_q[1]) check <- match(test, names) elem_color <- q[[i]]$color - if(is.na(check) != T){ + if(!is.na(check)){ elem_data <- NULL } else{ @@ -86,18 +86,18 @@ ElemBarDat <- function(q, data1, first_col, exp, names, palette, mbdata){ if(!is.null(exp)){ elem_data <- Subset_att(elem_data, exp) } - elem_data <- as.data.frame(count(elem_data[names])) + elem_data <- as.data.frame(count_compat(elem_data[names])) names(elem_data) <- c(names, "freq") elem_data <- elem_data[which(rowSums(elem_data[names]) != 0), ] x <- merge(mbdata, elem_data[names], by = names) elem_data <- merge(x[names], elem_data, by = names) x <- x$x elem_data$x <- x - if((isTRUE(q[[i]]$active) == T) && (is.null(elem_data) == F)){ - act <- T + if(isTRUE(q[[i]]$active) && !is.null(elem_data)){ + act <- TRUE } - else if((isTRUE(q[[i]]$active) == F || is.null(q[[i]]$active) == T) && (is.null(elem_data) == F)){ - act <- F + else if((!isTRUE(q[[i]]$active) || is.null(q[[i]]$active)) && !is.null(elem_data)){ + act <- FALSE } elem_data$color <- elem_color elem_data$act <- act diff --git a/R/General.query.funcs.R b/R/General.query.funcs.R index 6196fec..f15f226 100644 --- a/R/General.query.funcs.R +++ b/R/General.query.funcs.R @@ -3,18 +3,18 @@ SeperateQueries <- function(queries, choice, palette) { seperated <- list() for (i in 1:length(queries)) { - if (is.null(queries[[i]]$color) == T) { + if (is.null(queries[[i]]$color)) { queries[[i]]$color <- palette[1] palette <- palette[-1] } - else if (is.null(queries[[i]]$color) == F) { + else if (!is.null(queries[[i]]$color)) { next } } if (choice == 1) { for (i in 1:length(queries)) { - if (identical(intersects, queries[[i]]$query) == T || - identical(elements, queries[[i]]$query) == T) { + if (identical(intersects, queries[[i]]$query) || + identical(elements, queries[[i]]$query)) { seperated <- c(seperated, list(queries[[i]])) } else{ @@ -24,8 +24,8 @@ SeperateQueries <- function(queries, choice, palette) { } else if (choice == 2) { for (i in 1:length(queries)) { - if (identical(intersects, queries[[i]]$query) == F && - identical(elements, queries[[i]]$query) == F) { + if (!identical(intersects, queries[[i]]$query) && + !identical(elements, queries[[i]]$query)) { seperated <- c(seperated, list(queries[[i]])) } else{ @@ -61,18 +61,18 @@ GuideGenerator <- function(queries, palette) { return(NULL) } for (i in 1:length(queries)) { - if (is.null(queries[[i]]$color) == T) { + if (is.null(queries[[i]]$color)) { queries[[i]]$color <- palette[1] palette <- palette[-1] } - else if (is.null(queries[[i]]$color) == F) { + else if (!is.null(queries[[i]]$color)) { queries[[i]]$color <- queries[[i]]$color } colors[i] <- queries[[i]]$color - if (is.null(queries[[i]]$query.name) == FALSE) { + if (!is.null(queries[[i]]$query.name)) { numbers[i] <- queries[[i]]$query.name } - else if (is.null(queries[[i]]$query.name) == TRUE) { + else if (is.null(queries[[i]]$query.name)) { numbers[i] <- paste("Query", as.character(i), sep = "") } } diff --git a/R/Helper.funcs.R b/R/Helper.funcs.R index af9f8bc..4a42744 100644 --- a/R/Helper.funcs.R +++ b/R/Helper.funcs.R @@ -47,7 +47,7 @@ FindMostFreq <- function(data, start_col, end_col, n_sets){ temp_data <- data[ ,start_col:end_col] temp_data <- colSums(temp_data) temp_data <- as.data.frame(temp_data) - temp_data <- tail(temp_data[order(temp_data[ ,"temp_data"]), , drop = F], as.integer(n_sets)) + temp_data <- tail(temp_data[order(temp_data[ ,"temp_data"]), , drop = FALSE], as.integer(n_sets)) temp_data <- rev(row.names(temp_data)) return(temp_data) } @@ -55,17 +55,17 @@ FindMostFreq <- function(data, start_col, end_col, n_sets){ ## Finds the names of the sets that aren't being used Remove <- function(data, start_col, end_col, sets){ temp_data <- as.data.frame(data[ , start_col:end_col]) - Unwanted_sets <- colnames(temp_data[ ,!(colnames(temp_data) %in% sets), drop = F]) + Unwanted_sets <- colnames(temp_data[ ,!(colnames(temp_data) %in% sets), drop = FALSE]) } ## Removes unwanted sets from data Wanted <- function(data, unwanted_sets){ - temp_data <- (data[ ,!(colnames(data) %in% unwanted_sets), drop = F]) + temp_data <- (data[ ,!(colnames(data) %in% unwanted_sets), drop = FALSE]) } order_sets <- function(data, sets){ sets <- colSums(data[sets]) - sets <- names(sets[order(sets, decreasing = T)]) + sets <- names(sets[order(sets, decreasing = TRUE)]) return(sets) } @@ -73,7 +73,7 @@ order_sets <- function(data, sets){ Subset_att <- function(data, exp){ express <- unlist(strsplit(exp, " ")) for(i in seq_along(express)){ - if(is.na(match(express[i], colnames(data))) == F){ + if(!is.na(match(express[i], colnames(data)))){ express[i] <- paste("data$",express[i], sep = "") } else{ @@ -107,14 +107,14 @@ Get_aggregates <- function(data, num_sets, order_mat, cut){ } for(i in order_cols){ if(i == (num_sets + 1)){ - logic <- T + logic <- TRUE } else{ - logic <- F + logic <- FALSE } temp_data <- temp_data[order(temp_data[ , i], decreasing = logic), ] } - if(is.null(cut) == F){ + if(!is.null(cut)){ temp_data <- temp_data[1:cut, ] } set_agg <- rbind(set_agg, temp_data) @@ -139,14 +139,14 @@ OverlayEdit <- function(data1, data2, start_col, num_sets, intersects, exp, inte else{ temp_data <- temp_data[which(rowSums(temp_data[ ,start_col:new_end]) == length(intersects)), ] } - if(is.null(exp) == F){ + if(!is.null(exp)){ temp_data <- Subset_att(temp_data, exp) } temp_data <- temp_data[intersects] temp_data <- na.omit(temp_data) other_data <- data2[which(rowSums(data2[ ,1:num_sets]) == length(intersects)), ] - other_data <- (other_data[ ,!(colnames(data2) %in% unwanted), drop = F]) + other_data <- (other_data[ ,!(colnames(data2) %in% unwanted), drop = FALSE]) if(new_end == start_col){ other_data <- other_data[ which(other_data[intersects] == 1), ] } diff --git a/R/Intersection.queries.R b/R/Intersection.queries.R index dad93ec..9317207 100644 --- a/R/Intersection.queries.R +++ b/R/Intersection.queries.R @@ -27,13 +27,13 @@ QuerieInterData <- function(query, data1, first_col, num_sets, data2, exp, names inter_color <- query[[i]]$color test <- as.character(index_q[1]) check <- match(test, names) - if(is.na(check) == T){ + if(is.na(check)){ inter_data <- NULL } else{ for( i in 1:length(index_q)){ double_check <- match(index_q[i], names) - if(is.na(double_check) == T){ + if(is.na(double_check)){ warning("Intersection or set may not be present in data set. Please refer to matrix.") } } @@ -65,17 +65,17 @@ QuerieInterBar <- function(q, data1, first_col, num_sets, data2, exp, names, pa inter_color <- q[[i]]$color test <- as.character(index_q[1]) check <- match(test, names) - if(is.na(check) == T){ + if(is.na(check)){ inter_data <- NULL } else{ inter_data <- OverlayEdit(data1, data2, first_col, num_sets, index_q, exp, inter_color) } - if((isTRUE(q[[i]]$active) == T) && (is.null(inter_data) == F)){ - act[i] <- T + if(isTRUE(q[[i]]$active) && !is.null(inter_data)){ + act[i] <- TRUE } - else if((isTRUE(q[[i]]$active) == F) && (is.null(inter_data) == F)){ - act[i] <- F + else if(!isTRUE(q[[i]]$active) && !is.null(inter_data)){ + act[i] <- FALSE } rows <- rbind(rows, inter_data) } @@ -94,21 +94,21 @@ QuerieInterAtt <- function(q, data, first_col, num_sets, att_x, att_y, exp, name inter_color <- unlist(q[[i]]$color) test <- as.character(index_q[1]) check <- match(test, names) - if(is.na(check) == T){ + if(is.na(check)){ intersect <- NULL } else{ intersect <- GetIntersects(data, first_col, index_q, num_sets) - if(is.na(att_y[i]) == T){ - if(is.null(exp) == F){ + if(is.na(att_y[i])){ + if(!is.null(exp)){ intersect <- Subset_att(intersect, exp) } if(nrow(intersect) != 0){ intersect$color <- inter_color } } - else if(is.na(att_y[i]) == F){ - if(is.null(exp) == F){ + else if(!is.na(att_y[i])){ + if(!is.null(exp)){ intersect <- Subset_att(intersect, exp) } intersect$color <- inter_color diff --git a/R/MainBar.R b/R/MainBar.R index e9cf791..e1211c7 100644 --- a/R/MainBar.R +++ b/R/MainBar.R @@ -1,5 +1,3 @@ -#' @importFrom plyr count - ## Counts the frequency of each intersection being looked at and sets up data for main bar plot. ## Also orders the data for the bar plot and matrix plot Counter <- function(data, num_sets, start_col, name_of_sets, nintersections, mbar_color, order_mat, @@ -11,16 +9,16 @@ Counter <- function(data, num_sets, start_col, name_of_sets, nintersections, mba for( i in 1:num_sets){ temp_data[i] <- match(name_of_sets[i], colnames(data)) } - Freqs <- data.frame(count(data[ ,as.integer(temp_data)])) + Freqs <- data.frame(count_compat(data[ ,as.integer(temp_data)])) colnames(Freqs)[1:num_sets] <- name_of_sets #Adds on empty intersections if option is selected - if(is.null(empty_intersects) == F){ + if(!is.null(empty_intersects)){ empty <- rep(list(c(0,1)), times = num_sets) empty <- data.frame(expand.grid(empty)) colnames(empty) <- name_of_sets empty$freq <- 0 all <- rbind(Freqs, empty) - Freqs <- data.frame(all[!duplicated(all[1:num_sets]), ], check.names = F) + Freqs <- data.frame(all[!duplicated(all[1:num_sets]), ], check.names = FALSE) } #Remove universal empty set Freqs <- Freqs[!(rowSums(Freqs[ ,1:num_sets]) == 0), ] @@ -65,7 +63,7 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an bottom_margin <- (-1)*0.65 - if(is.null(attribute_plots) == FALSE){ + if(!is.null(attribute_plots)){ bottom_margin <- (-1)*0.45 } @@ -80,7 +78,7 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an intersection_size_number_scale <- text_scale } - if(is.null(Q) == F){ + if(!is.null(Q)){ inter_data <- Q if(nrow(inter_data) != 0){ inter_data <- inter_data[order(inter_data$x), ] @@ -89,7 +87,7 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an } else{inter_data <- NULL} - if(is.null(ebar) == F){ + if(!is.null(ebar)){ elem_data <- ebar if(nrow(elem_data) != 0){ elem_data <- elem_data[order(elem_data$x), ] @@ -99,8 +97,8 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an else{elem_data <- NULL} #ten_perc creates appropriate space above highest bar so number doesnt get cut off - if(is.null(ymax) == T){ - ten_perc <- ((max(Main_bar_data$freq)) * 0.1) + if(is.null(ymax)){ + ten_perc <- max(Main_bar_data$freq) * 0.1 ymax <- max(Main_bar_data$freq) + ten_perc } @@ -115,7 +113,7 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an Main_bar_data$freq <- round(log10(Main_bar_data$freq), 2) ymax <- log10(ymax) } - Main_bar_plot <- (ggplot(data = Main_bar_data, aes_string(x = "x", y = "freq")) + Main_bar_plot <- (ggplot(data = Main_bar_data, aes(x = .data$x, y = .data$freq)) + scale_y_continuous(trans = scale_intersections) + ylim(0, ymax) + geom_bar(stat = "identity", width = 0.6, @@ -125,14 +123,14 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an + xlab(NULL) + ylab(ylabel) +labs(title = NULL) + theme(panel.background = element_rect(fill = "white"), plot.margin = unit(c(0.5,0.5,bottom_margin,0.5), "lines"), panel.border = element_blank(), - axis.title.y = element_text(vjust = -0.8, size = 8.3*y_axis_title_scale), axis.text.y = element_text(vjust=0.3, - size=7*y_axis_tick_label_scale))) + axis.title.y = element_text(vjust = -0.8, size = 8.3*y_axis_title_scale), + axis.text.y = element_text(vjust=0.3, size=7*y_axis_tick_label_scale))) if((show_num == "yes") || (show_num == "Yes")){ if(is.null(number.colors)) { - Main_bar_plot <- (Main_bar_plot + geom_text(aes_string(label = "freq"), size = 2.2*intersection_size_number_scale, vjust = -1, + Main_bar_plot <- (Main_bar_plot + geom_text(aes(label = .data$freq), size = 2.2*intersection_size_number_scale, vjust = -1, angle = number_angles, colour = Main_bar_data$color)) } else { - Main_bar_plot <- (Main_bar_plot + geom_text(aes_string(label = "freq"), size = 2.2*intersection_size_number_scale, vjust = -1, + Main_bar_plot <- (Main_bar_plot + geom_text(aes(label = .data$freq), size = 2.2*intersection_size_number_scale, vjust = -1, angle = number_angles, colour = number.colors)) } } @@ -143,49 +141,49 @@ Make_main_bar <- function(Main_bar_data, Q, show_num, ratios, customQ, number_an pCustomDat <- NULL bElemDat <- NULL pElemDat <- NULL - if(is.null(elem_data) == F){ - bElemDat <- elem_data[which(elem_data$act == T), ] + if(!is.null(elem_data)){ + bElemDat <- elem_data[which(elem_data$act), ] bElemDat <- bElemDat[order(bElemDat$x), ] - pElemDat <- elem_data[which(elem_data$act == F), ] + pElemDat <- elem_data[which(!elem_data$act), ] } - if(is.null(inter_data) == F){ - bInterDat <- inter_data[which(inter_data$act == T), ] + if(!is.null(inter_data)){ + bInterDat <- inter_data[which(inter_data$act), ] bInterDat <- bInterDat[order(bInterDat$x), ] - pInterDat <- inter_data[which(inter_data$act == F), ] + pInterDat <- inter_data[which(!inter_data$act), ] } if(length(customQ) != 0){ - pCustomDat <- customQ[which(customQ$act == F), ] - bCustomDat <- customQ[which(customQ$act == T), ] + pCustomDat <- customQ[which(!customQ$act), ] + bCustomDat <- customQ[which(customQ$act), ] bCustomDat <- bCustomDat[order(bCustomDat$x), ] } if(length(bInterDat) != 0){ Main_bar_plot <- Main_bar_plot + geom_bar(data = bInterDat, - aes_string(x="x", y = "freq"), + aes(x = .data$x, y = .data$freq), fill = bInterDat$color, stat = "identity", position = "identity", width = 0.6) } if(length(bElemDat) != 0){ Main_bar_plot <- Main_bar_plot + geom_bar(data = bElemDat, - aes_string(x="x", y = "freq"), + aes(x = .data$x, y = .data$freq), fill = bElemDat$color, stat = "identity", position = "identity", width = 0.6) } if(length(bCustomDat) != 0){ - Main_bar_plot <- (Main_bar_plot + geom_bar(data = bCustomDat, aes_string(x="x", y = "freq2"), + Main_bar_plot <- (Main_bar_plot + geom_bar(data = bCustomDat, aes(x = .data$x, y = .data$freq2), fill = bCustomDat$color2, stat = "identity", position ="identity", width = 0.6)) } if(length(pCustomDat) != 0){ - Main_bar_plot <- (Main_bar_plot + geom_point(data = pCustomDat, aes_string(x="x", y = "freq2"), colour = pCustomDat$color2, + Main_bar_plot <- (Main_bar_plot + geom_point(data = pCustomDat, aes(x = .data$x, y = .data$freq2), colour = pCustomDat$color2, size = 2, shape = 17, position = position_jitter(width = 0.2, height = 0.2))) } if(length(pInterDat) != 0){ - Main_bar_plot <- (Main_bar_plot + geom_point(data = pInterDat, aes_string(x="x", y = "freq"), + Main_bar_plot <- (Main_bar_plot + geom_point(data = pInterDat, aes(x = .data$x, y = .data$freq), position = position_jitter(width = 0.2, height = 0.2), colour = pInterDat$color, size = 2, shape = 17)) } if(length(pElemDat) != 0){ - Main_bar_plot <- (Main_bar_plot + geom_point(data = pElemDat, aes_string(x="x", y = "freq"), + Main_bar_plot <- (Main_bar_plot + geom_point(data = pElemDat, aes(x = .data$x, y = .data$freq), position = position_jitter(width = 0.2, height = 0.2), colour = pElemDat$color, size = 2, shape = 17)) } diff --git a/R/Matrix.R b/R/Matrix.R index b828672..bcd685a 100644 --- a/R/Matrix.R +++ b/R/Matrix.R @@ -44,7 +44,7 @@ Create_layout <- function(setup, mat_color, mat_col, matrix_dot_alpha){ Matrix_layout$Intersection[i] <- paste(i, "No", sep = "") } } - if(is.null(mat_col) == F){ + if(!is.null(mat_col)){ for(i in 1:nrow(mat_col)){ mat_x <- mat_col$x[i] mat_color <- as.character(mat_col$color[i]) @@ -99,13 +99,15 @@ Make_matrix_plot <- function(Mat_data,Set_size_data, Main_bar_data, point_size, limits = c(0.5,(nrow(Set_size_data) +0.5)), labels = labels, expand = c(0,0)) + scale_x_continuous(limits = c(0,(nrow(Main_bar_data)+1 )), expand = c(0,0)) - + geom_rect(data = shading_data, aes_string(xmin = "min", xmax = "max", - ymin = "y_min", ymax = "y_max"), + + geom_rect(data = shading_data, + aes(xmin = .data$min, xmax = .data$max, + ymin = .data$y_min, ymax = .data$y_max), fill = shading_data$shade_color, alpha = shade_alpha) - + geom_point(data= Mat_data, aes_string(x= "x", y= "y"), colour = Mat_data$color, - size= point_size, alpha = Mat_data$alpha, shape=16) - + geom_line(data= Mat_data, aes_string(group = "Intersection", x="x", y="y", - colour = "color"), size = line_size) + + geom_point(data= Mat_data, aes(x = .data$x, y = .data$y), + colour = Mat_data$color, size = point_size, + alpha = Mat_data$alpha, shape = 16) + + geom_line(data= Mat_data, aes(group = .data$Intersection, x = .data$x, y = .data$y, + colour = .data$color), linewidth = line_size) + scale_color_identity()) Matrix_plot <- ggplot_gtable(ggplot_build(Matrix_plot)) return(Matrix_plot) diff --git a/R/Metadata.plots.R b/R/Metadata.plots.R index b38bbfe..ca11e20 100644 --- a/R/Metadata.plots.R +++ b/R/Metadata.plots.R @@ -2,11 +2,11 @@ metadataHist <- function(metadata, y_data, colors){ colnum <- match(y_data, names(metadata)) names(metadata)[colnum] <- "current" - if(is.numeric(metadata$current) == FALSE){ + if(!is.numeric(metadata$current)){ warning("The values supplied for the metadata histogram were not numeric") } metadata <- metadata[c(1,colnum)] - if(is.factor(metadata$current) == TRUE){ + if(is.factor(metadata$current)){ warning("The data being used for the bar plot is not numeric!") } names(metadata)[colnum] <- y_data @@ -16,7 +16,7 @@ metadataHist <- function(metadata, y_data, colors){ } plot <- (ggplot(data=metadata) - + geom_bar(aes_string(x="sets", y=y_data), + + geom_bar(aes(x= .data$sets, y=.data[[y_data]]), stat="identity", position="identity", width = 0.4, fill = colors) + scale_x_continuous(limits = c(0.5, (nrow(metadata)+0.5)), @@ -28,7 +28,7 @@ metadataHist <- function(metadata, y_data, colors){ axis.text.x = element_text(size = 7), axis.line = element_line(colour = "gray0"), axis.line.y = element_blank(), - axis.line.x = element_line(colour = "gray0", size = 0.3), + axis.line.x = element_line(colour = "gray0", linewidth = 0.3), axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid.minor = element_blank(), @@ -45,26 +45,26 @@ metadataHeat <- function(metadata, y_data, plot_type, colors){ "#CC79A7") colnum <- match(y_data, names(metadata)) names(metadata)[colnum] <- "current" - if(is.factor(metadata$current) == TRUE){ + if(is.factor(metadata$current)){ colortype <- "factor" levs <- levels(metadata$current) if(plot_type == "bool"){ - newlevel <- c(0,1) + newlevel <- c(0, 1) } else if(plot_type == "heat"){ - newlevel <- c(1:length(levs)) + newlevel <- seq_along(levs) } metadata$current <- as.character(metadata$current) - for(i in seq(length(levs))){ + for(i in seq_along(levs)){ metadata$current[which(metadata$current == levs[i])] <- newlevel[i] } metadata$current <- as.numeric(metadata$current) } - else if(is.character(metadata$current) == TRUE){ + else if(is.character(metadata$current)){ colortype <- "category" uniquecats <- length(unique(metadata$current)) } - else if(is.numeric(metadata$current) == TRUE){ + else if(is.numeric(metadata$current)){ if(plot_type != "bool"){ colortype <- "factor" } @@ -84,7 +84,7 @@ metadataHeat <- function(metadata, y_data, plot_type, colors){ titleAdjustment <- 25 #} - plot <- (ggplot(data=metadata, aes_string(x="sets", y = 1, fill = y_data)) + plot <- (ggplot(data = metadata, aes(x = .data$sets, y = 1, fill = .data[[y_data]])) + scale_x_continuous(expand = c(c(0,0), c(0,0))) + theme(panel.background = element_rect("white"), plot.title = element_text(margin = margin(b=titleAdjustment), @@ -100,9 +100,7 @@ metadataHeat <- function(metadata, y_data, plot_type, colors){ axis.title.y = element_blank(), axis.text.x = element_blank(), axis.ticks.x = element_blank()) - + ylab(NULL) - + xlab(NULL) - + ggtitle(y_data) + + labs(x = NULL, y = NULL, title = y_data) + coord_flip() + scale_y_reverse()) @@ -118,10 +116,10 @@ metadataHeat <- function(metadata, y_data, plot_type, colors){ } else if(is.null(colors) && nrow(metadata) >= 9){ - warning("Please provide color palette when number of groups exceeds 8") + warning("Please provide color palette when number of groups exceeds 8.") } - else if(is.null(colors) == FALSE){ + else if(!is.null(colors)){ plot <- plot + geom_tile() plot <- plot + scale_fill_manual(values = colors) } @@ -167,11 +165,11 @@ metadataText <- function(metadata, y_data, colors, alignment){ ncols <- ncol(metadata) metadata <- cbind(metadata, c(1:nrow(metadata))) names(metadata)[ncol(metadata)] <- "x" - plot <- (ggplot(data=metadata, aes_string(x="x", y=1, label = y_data, colour = y_data, size =10)) + plot <- (ggplot(data=metadata, aes(x = .data$x, y = 1, label = .data[[y_data]], colour = .data[[y_data]], size = 10)) + scale_x_continuous(limits = c(0.5, (nrow(metadata)+0.5)), expand = c(0,0)) + theme(panel.background = element_rect("white"), - plot.title = element_text(margin = margin(b=titleAdjustment), + plot.title = element_text(margin = margin(b = titleAdjustment), size = 9, hjust = 0.5), plot.margin=unit(c(0,0,0,0), "lines"), axis.title.x = element_text(size = 7), @@ -184,12 +182,10 @@ metadataText <- function(metadata, y_data, colors, alignment){ axis.title.y = element_blank(), axis.text.x = element_blank(), axis.ticks.x = element_blank()) - + xlab(NULL) - + ylab(NULL) + + labs(x = NULL, y = NULL, title = y_data) + coord_flip() - + ggtitle(y_data) + scale_y_reverse()) - if(is.null(colors) == FALSE){ + if(!is.null(colors)){ plot <- plot + geom_text(size = 2.7, hjust = align) plot <- plot + scale_colour_manual(values = colors) } @@ -223,7 +219,7 @@ get_shade_groups <- function(set_metadata, set_names, Mat_data, shade_alpha) { shade_data$y_max[k] <- ((k) + 0.5) } shade_data$shade_color <- data$color - if(is.null(set_metadata$plots[[i]]$alpha) == TRUE){ + if(is.null(set_metadata$plots[[i]]$alpha)){ shade_data$alpha <- shade_alpha } else{ diff --git a/R/Set.metadata.R b/R/Set.metadata.R index 95d9d21..3d55352 100644 --- a/R/Set.metadata.R +++ b/R/Set.metadata.R @@ -26,7 +26,7 @@ Make_set_metadata_plot <- function(set.metadata, set_names){ if(num_of_att != 0){ for(i in 1:num_of_att){ - if(is.null(set.metadata$plots[[i]]$colors) == FALSE){ + if(!is.null(set.metadata$plots[[i]]$colors)){ colors <- set.metadata$plots[[i]]$colors } else{ diff --git a/R/SizeBar.R b/R/SizeBar.R index ebc7314..cf8c84e 100644 --- a/R/SizeBar.R +++ b/R/SizeBar.R @@ -5,8 +5,8 @@ FindSetFreqs <- function(data, start_col, num_sets, set_names, keep_order){ temp_data <- temp_data[set_names] temp_data <- as.data.frame(colSums(temp_data)) colnames(temp_data) <- c("y") - if(keep_order == FALSE){ - temp_data <- temp_data[order(temp_data$y, decreasing = T), ] + if(!keep_order){ + temp_data <- temp_data[order(temp_data$y, decreasing = TRUE), ] } else{ temp_data <- temp_data$y @@ -20,17 +20,16 @@ FindSetFreqs <- function(data, start_col, num_sets, set_names, keep_order){ log10_reverse_trans <- function(){ trans <- function(x) -log(x, 10) inv <- function(x) (10 ^ -x) - trans_new(paste0("reverselog2-", format(2), "reverse"), trans, inv, - log_breaks(base = 10), domain = c(1e-100, Inf)) + scales::trans_new(paste0("reverselog2-", format(2), "reverse"), trans, inv, + scales::log_breaks(base = 10), domain = c(1e-100, Inf)) } log2_reverse_trans <- function(){ trans <- function(x) -log(x, 2) inv <- function(x) (2 ^ -x) - trans_new(paste0("reverselog2-", format(2), "reverse"), trans, inv, - log_breaks(base = 2), domain = c(1e-100, Inf)) + scales::trans_new(paste0("reverselog2-", format(2), "reverse"), trans, inv, + scales::log_breaks(base = 2), domain = c(1e-100, Inf)) } -globalVariables(c("y")) ## Generate set size plot Make_size_plot <- function(Set_size_data, sbar_color, ratios, ylabel, scale_sets, text_scale, set_size_angle, set_size.show, set_size.scale_max, set_size.number_size){ @@ -69,7 +68,7 @@ Make_size_plot <- function(Set_size_data, sbar_color, ratios, ylabel, scale_sets num.size <- (7/2.845276)*x_axis_tick_label_scale } - Size_plot <- (ggplot(data = Set_size_data, aes_string(x ="x", y = "y")) + Size_plot <- (ggplot(data = Set_size_data, aes(x = .data$x, y = .data$y)) + geom_bar(stat = "identity",colour = sbar_color, width = 0.4, fill = sbar_color, position = "identity") + scale_x_continuous(limits = c(0.5, (nrow(Set_size_data) + 0.5)), @@ -82,7 +81,7 @@ Make_size_plot <- function(Set_size_data, sbar_color, ratios, ylabel, scale_sets vjust = 1, hjust = 0.5), axis.line = element_line(colour = "gray0"), axis.line.y = element_blank(), - axis.line.x = element_line(colour = "gray0", size = 0.3), + axis.line.x = element_line(colour = "gray0", linewidth = 0.3), axis.text.y = element_blank(), axis.ticks.y = element_blank(), panel.grid.minor = element_blank(), @@ -90,8 +89,8 @@ Make_size_plot <- function(Set_size_data, sbar_color, ratios, ylabel, scale_sets + xlab(NULL) + ylab(ylabel) + coord_flip()) - if(set_size.show == TRUE){ - Size_plot <- (Size_plot + geom_text(aes(label=y,vjust=0.5,hjust=1.2, angle = set_size_angle), size=num.size)) + if(set_size.show){ + Size_plot <- (Size_plot + geom_text(aes(label= .data$y), vjust=0.5,hjust=1.2, size=num.size, angle = set_size_angle)) } if(scale_sets == "log10"){ diff --git a/R/Specific.intersections.R b/R/Specific.intersections.R index f1acb15..6d1194c 100644 --- a/R/Specific.intersections.R +++ b/R/Specific.intersections.R @@ -7,7 +7,7 @@ specific_intersections <- function(data, first.col, last.col, intersections, ord if(length(remove) != 0){ data <- data[-remove] } - data <- count(data[keep]) + data <- count_compat(data[keep]) sets <- names(data[1:length(keep)]) data <- lapply(intersections, function(x){ temp_sets <- unlist(x) diff --git a/R/UpSet.plot.R b/R/UpSet.plot.R index 27ab9d8..831d671 100644 --- a/R/UpSet.plot.R +++ b/R/UpSet.plot.R @@ -1,12 +1,3 @@ -#' @importFrom grid grid.newpage -#' @importFrom grid pushViewport -#' @importFrom grid viewport -#' @importFrom grid grid.layout -#' @importFrom grid grid.draw -#' @importFrom grid popViewport -#' @importFrom grid legendGrob -#' @importFrom grid gpar - ## Assemble plots to make UpSet plot Make_base_plot <- function(Main_bar_plot, Matrix_plot, Size_plot, labels, hratios, att_x, att_y, Set_data, exp, position, start_col, att_color, QueryData, diff --git a/R/UpSetR-package.R b/R/UpSetR-package.R new file mode 100644 index 0000000..9cb96ff --- /dev/null +++ b/R/UpSetR-package.R @@ -0,0 +1,16 @@ +#' @keywords internal +"_PACKAGE" + +## usethis namespace: start +#' @importFrom rlang .data %||% +#' @import gridExtra +#' @import ggplot2 +#' @import utils +#' @import stats +#' @import methods +#' @import grDevices +#' @importFrom grid grid.newpage pushViewport viewport grid.layout grid.draw popViewport +#' @importFrom grid legendGrob gpar +#' @importFrom ggplot2 aes ggplot geom_histogram theme element_blank element_text +## usethis namespace: end +NULL diff --git a/R/count-compat.R b/R/count-compat.R new file mode 100644 index 0000000..087f19c --- /dev/null +++ b/R/count-compat.R @@ -0,0 +1,11 @@ +# This function aims to mimic plyr::count when vars or wt is not used. +# It would also be possible to use dplyr::count, but this avoids adding a new dependency +# to the package +count_compat <- function(x) { + if ("freq" %in% names(x)) warning("Used the weighting possibly (Internal)") + res <- vctrs::vec_count(x, sort = "key") + + rownames(res) <- NULL + + cbind(res$key, freq = res$count) +} diff --git a/R/fromExpression.R b/R/fromExpression.R index 9639767..1704495 100644 --- a/R/fromExpression.R +++ b/R/fromExpression.R @@ -20,7 +20,7 @@ fromExpression <- function(input){ cols[!is.na(cols)] <- 1 cols[is.na(cols)] <- 0 cols <- rep(cols, times = counts[[1]][i]) - cols <- matrix(cols, ncol = length(sets), byrow = T) + cols <- matrix(cols, ncol = length(sets), byrow = TRUE) cols <- data.frame(cols) names(cols) <- sets data <- rbind(data, cols) diff --git a/R/histogram.R b/R/histogram.R index c0516d1..a02ab4e 100644 --- a/R/histogram.R +++ b/R/histogram.R @@ -6,7 +6,7 @@ #' @note See examples section for upset function on how to use custom.plot parameter #' @export histogram <- function(mydata, x){ - att_plot <- (ggplot(data = mydata, aes_string(x = x, fill = "color")) + att_plot <- (ggplot(data = mydata, aes(x = .data[[x]], fill = .data$color)) + scale_fill_identity() + geom_histogram(binwidth = 1) + ylab("Frequency") diff --git a/R/scatter_plot.R b/R/scatter_plot.R index 074dde6..713d3bd 100644 --- a/R/scatter_plot.R +++ b/R/scatter_plot.R @@ -7,8 +7,8 @@ #' @note See examples section for upset function on how to use custom.plot parameter. #' @export scatter_plot <- function(mydata, x, y){ - att_plot <- (ggplot(data = mydata, aes_string(x = x, y = y, colour = "color")) - + geom_point(shape=16) + scale_color_identity() + att_plot <- (ggplot(data = mydata, aes(x = .data[[x]], y = .data[[y]], colour = .data$color)) + + geom_point(shape = 16) + scale_color_identity() + theme(panel.background = element_rect(fill = "white"), plot.title = element_text(vjust = 1.3), panel.grid.minor = element_blank(), diff --git a/R/upset.R b/R/upset.R index 20c09c8..bba9d91 100644 --- a/R/upset.R +++ b/R/upset.R @@ -43,7 +43,8 @@ #' @param matrix.dot.alpha Transparency of the empty intersections points in the matrix #' @param empty.intersections Additionally display empty sets up to nintersects #' @param color.pal Color palette for attribute plots -#' @param boxplot.summary Boxplots representing the distribution of a selected attribute for each intersection. Select attributes by entering a character vector of attribute names (e.g. c("Name1", "Name2")). +#' @param boxplot.summary Boxplots representing the distribution of a selected attribute for each intersection. +#' Select attributes by entering a character vector of attribute names (e.g. c("Name1", "Name2")). #' The maximum number of attributes that can be entered is 2. #' @param attribute.plots Create custom ggplot using intersection data represented in the main bar plot. Prior to adding custom plots, the UpSet plot is set up in a 100 by 100 grid. #' The attribute.plots parameter takes a list that contains the number of rows that should be allocated for the custom plot, and a list of plots with specified positions. @@ -69,22 +70,24 @@ #' @references Lex and Gehlenborg (2014). Points of view: Sets and intersections. Nature Methods 11, 779 (2014). \url{http://www.nature.com/nmeth/journal/v11/n8/abs/nmeth.3033.html} #' @seealso Original UpSet Website: \url{http://vcg.github.io/upset/about/} #' @seealso UpSetR github for additional examples: \url{http://github.com/hms-dbmi/UpSetR} -#' @examples movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), header=TRUE, sep=";" ) +#' @examples +#' movies <- read.csv(system.file("extdata", "movies.csv", package = "UpSetR"), +#' header = TRUE, sep = ";") #' -#'require(ggplot2); require(plyr); require(gridExtra); require(grid); +#'require(ggplot2); require(gridExtra); require(grid); #' #' between <- function(row, min, max){ #' newData <- (row["ReleaseDate"] < max) & (row["ReleaseDate"] > min) #' } #' #' plot1 <- function(mydata, x){ -#' myplot <- (ggplot(mydata, aes_string(x= x, fill = "color")) +#' myplot <- (ggplot(mydata, aes(x = .data[[x]], fill = color)) #' + geom_histogram() + scale_fill_identity() #' + theme(plot.margin = unit(c(0,0,0,0), "cm"))) #' } #' #' plot2 <- function(mydata, x, y){ -#' myplot <- (ggplot(data = mydata, aes_string(x=x, y=y, colour = "color"), alpha = 0.5) +#' myplot <- (ggplot(data = mydata, aes(x = .data[[x]], y = .data[[y]], colour = color), alpha = 0.5) #' + geom_point() + scale_color_identity() #' + theme_bw() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) #' } @@ -109,20 +112,13 @@ #' list(query = elements, params = list("ReleaseDate", 1990, 1991, 1992))), #' main.bar.color = "yellow") #' -#' @import gridExtra -#' @import ggplot2 -#' @import utils -#' @import stats -#' @import methods -#' @import grDevices -#' @import scales #' @export -upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F, set.metadata = NULL, intersections = NULL, +upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = FALSE, set.metadata = NULL, intersections = NULL, matrix.color = "gray23", main.bar.color = "gray23", mainbar.y.label = "Intersection Size", mainbar.y.max = NULL, sets.bar.color = "gray23", plot.title = NA, sets.x.label = "Set Size", point.size = 2.2, line.size = 0.7, mb.ratio = c(0.70,0.30), expression = NULL, att.pos = NULL, att.color = main.bar.color, order.by = c("freq", "degree"), - decreasing = c(T, F), show.numbers = "yes", number.angles = 0, number.colors=NULL, group.by = "degree",cutoff = NULL, - queries = NULL, query.legend = "none", shade.color = "gray88", shade.alpha = 0.25, matrix.dot.alpha =0.5, + decreasing = c(TRUE, FALSE), show.numbers = "yes", number.angles = 0, number.colors=NULL, group.by = "degree",cutoff = NULL, + queries = NULL, query.legend = "none", shade.color = "gray88", shade.alpha = 0.25, matrix.dot.alpha = 0.5, empty.intersections = NULL, color.pal = 1, boxplot.summary = NULL, attribute.plots = NULL, scale.intersections = "identity", scale.sets = "identity", text.scale = 1, set_size.angles = 0 , set_size.show = FALSE, set_size.numbers_size = NULL, set_size.scale_max = NULL){ @@ -139,26 +135,26 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F "#CC79A7") } - if(is.null(intersections) == F){ + if(!is.null(intersections)){ Set_names <- unique((unlist(intersections))) Sets_to_remove <- Remove(data, first.col, last.col, Set_names) New_data <- Wanted(data, Sets_to_remove) Num_of_set <- Number_of_sets(Set_names) - if(keep.order == F){ + if(!keep.order){ Set_names <- order_sets(New_data, Set_names) } All_Freqs <- specific_intersections(data, first.col, last.col, intersections, order.by, group.by, decreasing, cutoff, main.bar.color, Set_names) } - else if(is.null(intersections) == T){ + else if(is.null(intersections)){ Set_names <- sets - if(is.null(Set_names) == T || length(Set_names) == 0 ){ + if(is.null(Set_names) || length(Set_names) == 0 ){ Set_names <- FindMostFreq(data, first.col, last.col, nsets) } Sets_to_remove <- Remove(data, first.col, last.col, Set_names) New_data <- Wanted(data, Sets_to_remove) Num_of_set <- Number_of_sets(Set_names) - if(keep.order == F){ + if(!keep.order){ Set_names <- order_sets(New_data, Set_names) } All_Freqs <- Counter(New_data, Num_of_set, first.col, Set_names, nintersects, main.bar.color, @@ -170,8 +166,9 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F #i.e. if one custom plot had both x and y, and others had only x, the y's for the other plots were NA #if I decided to make the NULL case (all x and no y, or vice versa), there would have been alot more if/else statements #NA can be indexed so that we still get the non NA y aesthetics on correct plot. NULL cant be indexed. - att.x <- c(); att.y <- c(); - if(is.null(attribute.plots) == F){ + att.x <- c() + att.y <- c() + if(!is.null(attribute.plots)){ for(i in seq_along(attribute.plots$plots)){ if(length(attribute.plots$plots[[i]]$x) != 0){ att.x[i] <- attribute.plots$plots[[i]]$x @@ -189,7 +186,7 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F } BoxPlots <- NULL - if(is.null(boxplot.summary) == F){ + if(!is.null(boxplot.summary)){ BoxData <- IntersectionBoxPlot(All_Freqs, New_data, first.col, Set_names) BoxPlots <- list() for(i in seq_along(boxplot.summary)){ @@ -203,17 +200,17 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F Element <- NULL legend <- NULL EBar_data <- NULL - if(is.null(queries) == F){ + if(!is.null(queries)){ custom.queries <- SeperateQueries(queries, 2, palette) customDat <- customQueries(New_data, custom.queries, Set_names) legend <- GuideGenerator(queries, palette) legend <- Make_legend(legend) - if(is.null(att.x) == F && is.null(customDat) == F){ + if(!is.null(att.x) && !is.null(customDat)){ customAttDat <- CustomAttData(customDat, Set_names) } customQBar <- customQueriesBar(customDat, Set_names, All_Freqs, custom.queries) } - if(is.null(queries) == F){ + if(!is.null(queries)){ Intersection <- SeperateQueries(queries, 1, palette) Matrix_col <- intersects(QuerieInterData, Intersection, New_data, first.col, Num_of_set, All_Freqs, expression, Set_names, palette) @@ -227,12 +224,12 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F Matrix_layout <- Create_layout(Matrix_setup, matrix.color, Matrix_col, matrix.dot.alpha) Set_sizes <- FindSetFreqs(New_data, first.col, Num_of_set, Set_names, keep.order) Bar_Q <- NULL - if(is.null(queries) == F){ + if(!is.null(queries)){ Bar_Q <- intersects(QuerieInterBar, Intersection, New_data, first.col, Num_of_set, All_Freqs, expression, Set_names, palette) } QInter_att_data <- NULL QElem_att_data <- NULL - if((is.null(queries) == F) & (is.null(att.x) == F)){ + if(!is.null(queries) && !is.null(att.x)){ QInter_att_data <- intersects(QuerieInterAtt, Intersection, New_data, first.col, Num_of_set, att.x, att.y, expression, Set_names, palette) QElem_att_data <- elements(QuerieElemAtt, Element, New_data, first.col, expression, Set_names, att.x, att.y, @@ -242,19 +239,19 @@ upset <- function(data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F ShadingData <- NULL - if(is.null(set.metadata) == F){ + if(!is.null(set.metadata)){ ShadingData <- get_shade_groups(set.metadata, Set_names, Matrix_layout, shade.alpha) output <- Make_set_metadata_plot(set.metadata, Set_names) set.metadata.plots <- output[[1]] set.metadata <- output[[2]] - if(is.null(ShadingData) == FALSE){ + if(!is.null(ShadingData)){ shade.alpha <- unique(ShadingData$alpha) } } else { set.metadata.plots <- NULL } - if(is.null(ShadingData) == TRUE){ + if(is.null(ShadingData)){ ShadingData <- MakeShading(Matrix_layout, shade.color) } Main_bar <- suppressMessages(Make_main_bar(All_Freqs, Bar_Q, show.numbers, mb.ratio, customQBar, number.angles, number.colors, EBar_data, mainbar.y.label, diff --git a/README.md b/README.md index 3ed052a..6aea694 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,10 @@ -# UpSetR [![](http://www.r-pkg.org/badges/version/UpSetR)](https://cran.r-project.org/package=UpSetR) [![](http://cranlogs.r-pkg.org/badges/grand-total/UpSetR)](http://cranlogs.r-pkg.org/badges/grand-total/UpSetR) +# UpSetR + + + [![](http://www.r-pkg.org/badges/version/UpSetR)](https://cran.r-project.org/package=UpSetR) + [![](http://cranlogs.r-pkg.org/badges/grand-total/UpSetR)](http://cranlogs.r-pkg.org/badges/grand-total/UpSetR) + [![R-CMD-check](https://github.com/hms-dbmi/UpSetR/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/hms-dbmi/UpSetR/actions/workflows/R-CMD-check.yaml) + ## Technique @@ -89,8 +95,8 @@ Install the latest released version from CRAN install.packages("UpSetR") ``` -Download the latest development code of UpSetR from GitHub using [devtools](https://cran.r-project.org/package=devtools) with +Download the latest development code of UpSetR from GitHub using [remotes](https://cran.r-project.org/package=remotes) with ```R -devtools::install_github("hms-dbmi/UpSetR") +remotes::install_github("hms-dbmi/UpSetR") ``` diff --git a/man/UpSetR-package.Rd b/man/UpSetR-package.Rd new file mode 100644 index 0000000..f4fe969 --- /dev/null +++ b/man/UpSetR-package.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/UpSetR-package.R +\docType{package} +\name{UpSetR-package} +\alias{UpSetR} +\alias{UpSetR-package} +\title{UpSetR: A More Scalable Alternative to Venn and Euler Diagrams for Visualizing Intersecting Sets} +\description{ +Creates visualizations of intersecting sets using a novel matrix design, along with visualizations of several common set, element and attribute related tasks (Conway 2017) \doi{10.1093/bioinformatics/btx364}. +} +\seealso{ +Useful links: +\itemize{ + \item \url{http://github.com/hms-dbmi/UpSetR} + \item Report bugs at \url{http://github.com/hms-dbmi/UpSetR/issues} +} + +} +\author{ +\strong{Maintainer}: Jake Conway \email{jake_conway@hms.harvard.edu} + +Authors: +\itemize{ + \item Nils Gehlenborg \email{nils@hms.harvard.edu} +} + +} +\keyword{internal} diff --git a/man/upset.Rd b/man/upset.Rd index 7947d64..75c76e1 100644 --- a/man/upset.Rd +++ b/man/upset.Rd @@ -9,7 +9,7 @@ upset( nsets = 5, nintersects = 40, sets = NULL, - keep.order = F, + keep.order = FALSE, set.metadata = NULL, intersections = NULL, matrix.color = "gray23", @@ -26,7 +26,7 @@ upset( att.pos = NULL, att.color = main.bar.color, order.by = c("freq", "degree"), - decreasing = c(T, F), + decreasing = c(TRUE, FALSE), show.numbers = "yes", number.angles = 0, number.colors = NULL, @@ -127,7 +127,8 @@ See examples section on how to do this.} \item{color.pal}{Color palette for attribute plots} -\item{boxplot.summary}{Boxplots representing the distribution of a selected attribute for each intersection. Select attributes by entering a character vector of attribute names (e.g. c("Name1", "Name2")). +\item{boxplot.summary}{Boxplots representing the distribution of a selected attribute for each intersection. +Select attributes by entering a character vector of attribute names (e.g. c("Name1", "Name2")). The maximum number of attributes that can be entered is 2.} \item{attribute.plots}{Create custom ggplot using intersection data represented in the main bar plot. Prior to adding custom plots, the UpSet plot is set up in a 100 by 100 grid. @@ -165,22 +166,23 @@ Depending on how the features are selected, UpSet can display between 25-65 sets Data set must be formatted as described on the original UpSet github page: \url{http://github.com/VCG/upset/wiki}. } \examples{ -movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), header=TRUE, sep=";" ) +movies <- read.csv(system.file("extdata", "movies.csv", package = "UpSetR"), + header = TRUE, sep = ";") -require(ggplot2); require(plyr); require(gridExtra); require(grid); +require(ggplot2); require(gridExtra); require(grid); between <- function(row, min, max){ newData <- (row["ReleaseDate"] < max) & (row["ReleaseDate"] > min) } plot1 <- function(mydata, x){ - myplot <- (ggplot(mydata, aes_string(x= x, fill = "color")) + myplot <- (ggplot(mydata, aes(x = .data[[x]], fill = color)) + geom_histogram() + scale_fill_identity() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) } plot2 <- function(mydata, x, y){ - myplot <- (ggplot(data = mydata, aes_string(x=x, y=y, colour = "color"), alpha = 0.5) + myplot <- (ggplot(data = mydata, aes(x = .data[[x]], y = .data[[y]], colour = color), alpha = 0.5) + geom_point() + scale_color_identity() + theme_bw() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) } diff --git a/vignettes/.gitignore b/vignettes/.gitignore new file mode 100644 index 0000000..caa9612 --- /dev/null +++ b/vignettes/.gitignore @@ -0,0 +1 @@ +*.R diff --git a/vignettes/attribute.plots.R b/vignettes/attribute.plots.R deleted file mode 100644 index fbe0122..0000000 --- a/vignettes/attribute.plots.R +++ /dev/null @@ -1,32 +0,0 @@ -## ---- tidy=TRUE---------------------------------------------------------- -library(UpSetR); library(ggplot2); library(grid); library(plyr) -movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), header=T, sep=";" ) - -## ---- fig.width=9, fig.height=5, out.width="850px",tidy=TRUE, fig.align='center'---- -upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), active = T)), attribute.plots = list(gridrows = 50, plots = list(list(plot = histogram, x = "ReleaseDate", queries = F), list(plot = histogram, x = "AvgRating", queries = T)), ncols = 2)) - -## ---- fig.width=9, fig.height=5,out.width="850px",tidy=TRUE, fig.align='center'---- -upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), color = "red", active = F), list(query = intersects, params = list("Action", "Drama"), active = T), list(query = intersects, params = list("Drama", "Comedy", "Action"), color = "orange", active = T)), attribute.plots = list(gridrows = 45, plots = list(list(plot = scatter_plot, x = "ReleaseDate", y = "AvgRating", queries = T), list(plot = scatter_plot, x = "AvgRating", y = "Watches", queries = F)), ncols = 2), query.legend = "bottom") - -## ---- tidy=TRUE---------------------------------------------------------- -myplot <- function(mydata,x,y){ - plot <- (ggplot(data = mydata, aes_string(x=x, y=y, colour = "color")) + geom_point() + scale_color_identity() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) -} - -another.plot <- function(data, x, y){ - data$decades <- round_any(as.integer(unlist(data[y])), 10, ceiling) - data <- data[which(data$decades >= 1970), ] - myplot <- (ggplot(data, aes_string(x=x)) + - geom_density(aes(fill=factor(decades)), alpha = 0.4) - +theme(plot.margin = unit(c(0,0,0,0), "cm"), legend.key.size = unit(0.4,"cm"))) -} - -## ---- fig.width=9, fig.height=5, out.width="850px",tidy=TRUE, fig.align='center'---- -upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), color = "red", active = F), list(query = intersects, params = list("Action", "Drama"), active = T), list(query = intersects, params = list("Drama", "Comedy", "Action"), color = "orange", active = T)), attribute.plots = list(gridrows = 45, plots = list(list(plot = myplot, x = "ReleaseDate", y = "AvgRating", queries = T), list(plot = another.plot, x = "AvgRating", y = "ReleaseDate", queries = F)), ncols = 2)) - -## ---- fig.width=9, fig.height=5,out.width="850px",tidy=TRUE, fig.align='center'---- -upset(movies, main.bar.color = "black", mb.ratio = c(0.5,0.5), queries = list(list(query = intersects, params = list("Drama"), color = "red", active = F), list(query = intersects, params = list("Action", "Drama"), active = T), list(query = intersects, params = list("Drama", "Comedy", "Action"), color = "orange", active = T)), attribute.plots = list(gridrows=50, plots = list(list(plot = histogram, x = "ReleaseDate", queries = F), list(plot = scatter_plot, x = "ReleaseDate", y = "AvgRating", queries = T),list(plot = myplot, x = "AvgRating", y = "Watches", queries = F)), ncols = 3)) - -## ---- fig.width=9, fig.height=5,out.width="850px", tidy=TRUE, fig.align='center'---- -upset(movies, boxplot.summary = c("AvgRating", "ReleaseDate")) - diff --git a/vignettes/attribute.plots.Rmd b/vignettes/attribute.plots.Rmd index c23f82e..5dcbd45 100644 --- a/vignettes/attribute.plots.Rmd +++ b/vignettes/attribute.plots.Rmd @@ -11,8 +11,10 @@ vignette: > For all examples the movies data set contained in the package will be used. ```{r, tidy=TRUE} -library(UpSetR); library(ggplot2); library(grid); library(plyr) -movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), header=T, sep=";" ) +library(UpSetR) +library(ggplot2) +library(grid) +movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), header = TRUE, sep=";" ) ```
@@ -43,7 +45,7 @@ Example 1: Built-In Attribute Histogram ------------- Example of how to add built-in histogram attribute plot. If `main.bar.color` is not specified as black, elements contained in black intersection size bars will be represented as gray in attribute plots. ```{r, fig.width=9, fig.height=5, out.width="850px",tidy=TRUE, fig.align='center'} -upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), active = T)), attribute.plots = list(gridrows = 50, plots = list(list(plot = histogram, x = "ReleaseDate", queries = F), list(plot = histogram, x = "AvgRating", queries = T)), ncols = 2)) +upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), active = T)), attribute.plots = list(gridrows = 50, plots = list(list(plot = histogram, x = "ReleaseDate", queries = F), list(plot = histogram, x = "AvgRating", queries = TRUE)), ncols = 2)) ```
@@ -61,16 +63,25 @@ upset(movies, main.bar.color = "black", queries = list(list(query = intersects, Example 3: Creating a Custom Attribute Plot ------------- -Contents of `aes_string()` along with the `scale_color_identity()` function are **required** to pass in aesthetics and to make sure the correct colors are applied. A `plot.margin` of `c(0.5,0,0,1)` is **recommended**. +Contents of `aes()` along with the `scale_color_identity()` function are **required** to pass in aesthetics and to make sure the correct colors are applied. A `plot.margin` of `c(0.5,0,0,1)` is **recommended**. + +```{r, include=FALSE} +# inlined from plyr +round_any <- function(x, accuracy, f) { + f(x/accuracy) * accuracy +} +``` + + ```{r, tidy=TRUE} myplot <- function(mydata,x,y){ - plot <- (ggplot(data = mydata, aes_string(x=x, y=y, colour = "color")) + geom_point() + scale_color_identity() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) + plot <- (ggplot(data = mydata, aes(x= .data[[x]], y = .data[[y]], colour = color)) + geom_point() + scale_color_identity() + theme(plot.margin = unit(c(0,0,0,0), "cm"))) } another.plot <- function(data, x, y){ data$decades <- round_any(as.integer(unlist(data[y])), 10, ceiling) data <- data[which(data$decades >= 1970), ] - myplot <- (ggplot(data, aes_string(x=x)) + + myplot <- (ggplot(data, aes(x = .data[[x]])) + geom_density(aes(fill=factor(decades)), alpha = 0.4) +theme(plot.margin = unit(c(0,0,0,0), "cm"), legend.key.size = unit(0.4,"cm"))) } @@ -78,7 +89,7 @@ another.plot <- function(data, x, y){ Example of applying the `myplot` custom attribute plot defined above to the data. ```{r, fig.width=9, fig.height=5, out.width="850px",tidy=TRUE, fig.align='center'} -upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), color = "red", active = F), list(query = intersects, params = list("Action", "Drama"), active = T), list(query = intersects, params = list("Drama", "Comedy", "Action"), color = "orange", active = T)), attribute.plots = list(gridrows = 45, plots = list(list(plot = myplot, x = "ReleaseDate", y = "AvgRating", queries = T), list(plot = another.plot, x = "AvgRating", y = "ReleaseDate", queries = F)), ncols = 2)) +upset(movies, main.bar.color = "black", queries = list(list(query = intersects, params = list("Drama"), color = "red", active = F), list(query = intersects, params = list("Action", "Drama"), active = T), list(query = intersects, params = list("Drama", "Comedy", "Action"), color = "orange", active = T)), attribute.plots = list(gridrows = 45, plots = list(list(plot = myplot, x = "ReleaseDate", y = "AvgRating", queries = T), list(plot = another.plot, x = "AvgRating", y = "ReleaseDate", queries = FALSE)), ncols = 2)) ```
diff --git a/vignettes/attribute.plots.html b/vignettes/attribute.plots.html index a49f08c..746518b 100644 --- a/vignettes/attribute.plots.html +++ b/vignettes/attribute.plots.html @@ -1,12 +1,12 @@ - + - + @@ -14,179 +14,454 @@ Attribute Plots - + + - - - - - - - + + + + + + + + + + + + + + + + + + - - + + -
- - - + + + +
-