{"post_id":58358837,"creation_date":"2019-10-12 21:47:19","snippet":"dyn.load(\"power.dll\") # dll created with gfortran -shared -fPIC -o power.dll power.f90\nx <- 3.0\nfoo <- .C(\"square_\",as.double(x),as.double(0.0))\nprint(foo)\nbar <- .C(\"pow_\",as.character(\"c\"),as.double(x),as.double(0.0))\nprint(bar)\n"} {"post_id":38879849,"creation_date":"2016-08-10 17:23:39","snippet":"library(dplyr)\nlibrary(tidyr)\nlibrary(purrr)\ndf <- data.frame(y = rnorm(10), \n x1 = runif(10),\n x2 = runif(10))\n\ndf %>%\n gather(covariate, value, x1:x2) %>% \n group_by(covariate) %>% \n nest() %>% \n mutate(model = map(.x = data , .f = ~lm(y ~ value, data = .))) %>% \n mutate(rsquared = map_dbl(.x = model, .f = ~summary(.)$r.squared))\n"} {"post_id":19869145,"creation_date":"2013-11-08 21:50:38","snippet":"set.seed(1)\nDT <- data.table(VAL = sample(c(1, 2, 3), 10, replace = TRUE))\n VAL\n 1: 1\n 2: 2\n 3: 2\n 4: 3\n 5: 1\n 6: 3\n 7: 3\n 8: 2\n 9: 2\n10: 1\n"} {"post_id":38879951,"creation_date":"2016-08-10 17:30:56","snippet":"#Create the data frame\nvar.1 <-rep(c(1,5,3),2)\n\nMyVector <- c(\"I know Pete\", \"Jerry has a new job\",\"Victor is an employee\",\"How to work with Pete\",\"Too Many Students\",\"Bob is mean\")\n MyDF <-as.data.frame(cbind(var.1,MyVector))\n\n#Create a vector of a list of names I want to extract into a new column in the dataframe.\nExtract <- c(\"Jerry\",\"Pete\", \"Bob\", \"Victor\")\n\n#Match would be perfect if I could use it on character vectors\nMyDF$newvar <-match(MyDF$MyVector,Extract)\n"} {"post_id":38880389,"creation_date":"2016-08-10 17:54:27","snippet":"library(shiny)\nlibrary(DT)\n\nui <- shinyUI(fluidPage(\n DT::dataTableOutput('dtoMyTable')\n))\n\nserver <- shinyServer(function(input, output){\n output$dtoMyTable <- DT::renderDataTable({\n data.frame(Amount=c(1.00, 2.20, 4.15))\n })\n})\n\nshinyApp(ui = ui, server = server)\n"} {"post_id":38847967,"creation_date":"2016-08-09 10:12:40","snippet":"df <- merge(df1, df2) # <- how can I change this?\ndf$col1_y <- NULL\ndf$col2_y <- NULL\ndf <- withColumnRenamed(df, \"col1_x\", \"col1\")\ndf <- withColumnRenamed(df, \"col2_x\", \"col2\")\n"} {"post_id":19870823,"creation_date":"2013-11-09 00:22:37","snippet":"foo = function() print(ii)\neye_foo = function( ) { \n ii = 1 # (A)\n foo()\n}\neye_foo() # (B)\nii=2 # (C)\neye_foo() # (D)\n"} {"post_id":38880694,"creation_date":"2016-08-10 18:12:44","snippet":"install.packages(\"lme4\")\ninstall.packages(\"raster\")\ninstall.packages(\"rgdal\")\n\nlibrary(\"lme4\")\nlibrary(\"raster\")\nlibrary(\"rgdal\")\n\n# my data\ndata = structure(list(colorSymbol = c(1L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, \n1L, 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, \n0L, 0L, 0L, 1L, 0L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, \n0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L), bio_2 = c(75L, 168L, \n57L, 127L, 120L, 100L, 97L, 97L, 97L, 97L, 94L, 102L, 102L, 89L, \n89L, 102L, 96L, 97L, 92L, 100L, 97L, 97L, 97L, 96L, 97L, 95L, \n97L, 105L, 96L, 92L, 96L, 97L, 97L, 88L, 95L, 95L, 95L, 99L, \n96L, 97L, 97L, 100L, 97L, 96L, 94L, 94L, 94L, 94L, 98L, 94L), \nbio_3 = c(24L, 36L, 32L, 57L, 31L, 31L, 32L, 32L, 32L, 32L, \n31L, 33L, 31L, 32L, 32L, 33L, 32L, 31L, 32L, 33L, 32L, 32L, \n32L, 32L, 32L, 32L, 32L, 34L, 31L, 32L, 32L, 32L, 32L, 32L, \n32L, 32L, 32L, 31L, 32L, 32L, 32L, 34L, 31L, 32L, 31L, 31L, \n31L, 31L, 32L, 32L)), .Names = c(\"colorSymbol\", \"bio_2\", \n\"bio_3\"), row.names = c(NA, 50L), class = \"data.frame\")\n# model\nbio2 = data$bio_2\nbio3 = data$bio_3\ncolorSymbol = data$colorSymbol\nmodel = glm(colorSymbol ~ bio2 + bio3, family = binomial)\n# predictors\nw = getData('worldclim', var='bio', res=10)\nrasstack <- stack(w$bio2, w$bio3)\np <- raster::predict(rasstack, model)\nplot(p)\n"} {"post_id":38883938,"creation_date":"2016-08-10 21:33:38","snippet":"library(shiny)\nlibrary(EnvStats)\nui <- fluidPage ( \n sidebarLayout(\n sidebarPanel (\n numericInput('variable1', 'new x', 0.1, min = 0, max = 100, step = 0.1)\n ),\n mainPanel (plotOutput('plot1') )\n )\n )\nserver <- function(input, output){\n# Initial data and linear regression that should be reactive,\n# the dependency on input$variable1<1 is just an example to work with a lm based on reactive data. \n y<- reactive (\n if (input$variable1<1)\n { y <- c(3.1, 3.25, 3.5, 4, 3.5, 5, 5.5) }\n else \n { y <- c(.1, .25, .5, 1, 1.5, 2, 2.5) }\n )\n x<- reactive (\n if (input$variable1>=1)\n { x <- c(.1, .332, .631, .972, 1.201, 1.584, 1.912) }\n else \n { x <- c(.1, .3, .631, .972, 2.201, 2.584, 2.912) }\n )\n\noutput$plot1 <- renderPlot({\n # UNCORRECTED INITIAL VERSION some reactive functions are unnecessary \n # results <- reactive({ \n # r <- data.frame(y(),x())\n # })\n # lmod <- reactive ({ \n # mod1 <- lm(y()~ x(), data = results() \n # )\n # x <-reactive ({ x <- input$variable1 })\n # newdata <- reactive ({ data.frame(x() ) } )\n # newdata.pred <- reactive ({ predict(lmod(),newdata(),level=1)\n # })\n # segments(input$variable1, 0, input$variable1, newdata.pred(), col = \"red\")\n # CORRECTED AFTER MRFLICK\n plot(x(),y())\n results <- data.frame(y=y(),x=x()) # reactive is not necessary because \n lmod <- lm(y~x, data = results) #of the reactive context (renderPlot)\n abline(lmod) \n x <- input$variable1 \n newdata <- data.frame(x=x ) \n newdata.pred2 <- predict(lmod,newdata,se.fit=TRUE)\n ci<- pointwise(newdata.pred2, coverage = 0.95, simultaneous = TRUE)\n\n newdata.pred <- predict(lmod,newdata)\n\n segments(input$variable1, 0, input$variable1, newdata.pred, col = \"red\")\n points(input$variable1, ci$lower, col = \"magenta\") \n points(input$variable1, ci$upper, col = \"magenta\")\n text(input$variable1, newdata.pred, labels=paste(\"predicted\",signif(newdata.pred, 3) ), pos =4, cex = 1.2)\n text(input$variable1, ci$upper, labels=paste(\"upper limit of pointwise confidence intervals\",\n signif(ci$upper, 3) ), pos =4, cex = 1.2)\n text(input$variable1, ci$lower, labels=paste(\"lower limit of pointwise confidence intervals\",\n signif(ci$lower, 3) ), pos =4, cex = 1.2)\n} )\n} # end server\n shinyApp(ui, server)\n"} {"post_id":58418699,"creation_date":"2019-10-16 17:25:34","snippet":"library(tidyverse)\nlibrary(janitor)\n\ndummy1 <- runif(5000, 0, 1)\ndummy11 <- case_when(\n dummy1 < 0.776 ~ 1,\n dummy1 < 0.776 + 0.124 ~ 2,\n TRUE ~ 5)\n\ndf1 <- tibble(q1 = dummy11)\n"} {"post_id":58417268,"creation_date":"2019-10-16 15:51:54","snippet":"library(colourvision)\nlibrary(ggplot2)\nlibrary(grid)\n\ngradient <- t(rev(rainbow(20))) # higher value for smoother gradient\ng <- rasterGrob(gradient, width = unit(1, \"npc\"), height = unit(1, \"npc\"), interpolate = TRUE) \n\nhuman <- photor(lambda.max = c(420, 530, 560), lambda = seq(400, 700, 1))\n\nggplot(data = human, aes(x = Wavelength)) +\n annotation_custom(g, xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf) +\n geom_line(aes(y = lambda.max420), color = \"white\") +\n geom_line(aes(y = lambda.max530), color = \"white\") +\n geom_line(aes(y = lambda.max560), color = \"white\") +\n scale_x_continuous(breaks = seq(400, 700, 50)) +\n labs(x = NULL, y = NULL) # Save space for question\n"} {"post_id":19911134,"creation_date":"2013-11-11 16:25:33","snippet":"x <- seq(0, 10, .1)\ny <- sin(x)\nlbl <- ifelse(y > 0, 'positive', 'non-positive')\ndata.one <- data.frame(x=x, y=y, lbl=lbl)\n\ndata.two <- data.frame(x=c(0, 10, 0, 10), y=c(-0.5, -0.5, 0.5, 0.5), classification=c('low', 'low', 'high', 'high'))\nplt <- ggplot(data.one) + geom_point(aes(x, y, color=lbl)) + scale_color_discrete(name='one', guide='legend')\nplt <- plt + geom_line(data=data.two, aes(x, y, color=classification)) + scale_color_discrete(name='two', guide='legend')\nprint(plt)\n"} {"post_id":39511756,"creation_date":"2016-09-15 13:02:35","snippet":"xmin <- 8\nymin <- 11.5\nxmax <- 33\nymax <- 36.5\nboxsize <- 1\n\n# define coverage grid\ncov.grid <- matrix(c(xmin,ymin), nrow = 1, ncol = 2, byrow = FALSE)\ncolnames(cov.grid) <- c('x','y')\nx <- xmin\ny <- ymin\nwhile(x < xmax)\n {\n while(y < ymax)\n {\n y <- y+boxsize\n cov.grid <- rbind(cov.grid, c(x,y)) \n }\n x <- x+boxsize\n y <- ymin\n cov.grid <- rbind(cov.grid, c(x,y)) \n}\ncov.grid <- as.data.frame(cov.grid)\n\n\n# count grid cells occupied by fish\nday.row <- 1\ngrid.row <- 1\nbin <- 0\ncov.grid$occupied <- NA\n\nfor(grid.row in 1:nrow(cov.grid)){\nx1 <- cov.grid[grid.row,1]\ny1 <- cov.grid[grid.row,2]\nx2 <- x1+boxsize\ny2 <- cov.grid[grid.row+1,2] \nrepeat\n {\n if(dayfile[day.row,'PosX'] > x1 & dayfile[day.row,'PosX'] < x2 & dayfile[day.row,'PosY'] > y1 & dayfile[day.row,'PosY'] < y2) {bin <- 1} else {bin <- 0}\n day.row <- day.row+1\n if(bin == 1 | day.row == nrow(dayfile)){break}\n }\ncov.grid[grid.row,'occupied'] <- bin\nday.row <- 1\n}\n\n# return coverage summary\n\ncoverage <- matrix(c(length(which(cov.grid$occupied == 1)), nrow(cov.grid), length(which(cov.grid$occupied == 1))/nrow(cov.grid)), ncol = 3)\ncolnames(coverage) <- c('occupied', 'total', 'proportion')\ncoverage\n"} {"post_id":19503614,"creation_date":"2013-10-21 20:01:28","snippet":" library(twitteR)\n library(RJSONIO)\n\n\n #Authorize with Twitter's API\n reqURL <- \"https://api.twitter.com/oauth/request_token\"\n accessURL <- \"http://api.twitter.com/oauth/access_token\"\n authURL <- \"http://api.twitter.com/oauth/authorize\"\n consumerKey = \"myconsumerkey\"\n consumerSecret = \"myconsumersecret\"\n twitCred <- OAuthFactory$new(consumerKey=consumerKey,\n consumerSecret=consumerSecret,\n requestURL=reqURL,\n accessURL=accessURL,\n authURL=authURL)\n twitCred$handshake()\n\n B<-read.csv(\"BCorp RAW.csv\") \n handles<-B$Twitter.handle\n handles<-na.omit(handles)\n\n start <- getUser(handles[12]) \n\n library(rjson)\n friends.object<- lookupUsers(start$getFriendIDs(), includeNA=TRUE)\n followers.object<-lookupUsers(start$getFollowerIDs(), includeNA=TRUE)\n"} {"post_id":19503004,"creation_date":"2013-10-21 19:25:38","snippet":" dev.new(width=10, height=5)\n par(xaxs='i',yaxs='i')\n plot(q1, type = \"l\", lty = 1, lwd = 2, col = \"green\", xaxt = 'n', xlim = c(0,30), bty = \"l\")\n x.ticks = seq(from = 0, to = 30, by = 5)\n axis(1, at = x.ticks+1, labels=paste(\"Year\", x.ticks, sep=\" \"))\n"} {"post_id":38533842,"creation_date":"2016-07-22 19:15:51","snippet":"library(tools)\n#the files in the package main directory and subdirectories\nnames = (list.files(\"package_directory/\", recursive = T)) \nfiles = do.call(paste, list(\"package_directory\", names, sep = \"\")) \n#pasting the directory name so it forms a complete filename, can be skipped \n##if you set your working directory to the same directory as the package\n\n#md5 checksum generation\nmd5 = as.vector(md5sum(files))\n#aggregating it in a file\nexpt = do.call(paste, list(md5, names, sep = \" *\"))\n#and writing it to the package directory\nwrite(expt, \"package_directory/MD5\")\n"} {"post_id":58097212,"creation_date":"2019-09-25 11:20:27","snippet":"library(shiny)\nlibrary(DT)\n\nui <- fluidPage(\n DTOutput(\"table\"), \n textOutput(\"mean\")\n)\n\nserver <- function(input, output) {\n tableUpdate <- reactiveVal(0)\n\n table <- data.frame(A = 1:5, B = 6:10, C = 11:15)\n\n output$table <- renderDT({table},\n options = list(paging = FALSE, dom = 't'),\n selection = 'none',\n server = FALSE,\n editable = list(target = 'row')\n )\n\n observeEvent(input$table_cell_edit, {\n table <<- editData(table, input$table_cell_edit)\n tableUpdate(tableUpdate() + 1)\n })\n\n output$mean <- renderText({\n tableUpdate()\n paste(mean(table$A), mean(table$B), mean(table$C))\n })\n}\n\nshinyApp(ui, server)\n"} {"post_id":58097212,"creation_date":"2019-09-25 11:20:27","snippet":"library(shinytest)\n\napp <- ShinyDriver$new(\".\")\napp$setInputs(table_cell_clicked = list(row = 2, col = 2, value = 7), allowInputNoBinding_ = TRUE)\napp$setInputs(table_cell_edit = data.frame(row = 2, col = 0:3, value = \"1\"), \n allowInputNoBinding_ = TRUE, priority_ = \"event\", wait_ = FALSE, values_ = FALSE)\napp$takeScreenshot()\napp$stop()\nrm(app)\n"} {"post_id":58098416,"creation_date":"2019-09-25 12:29:08","snippet":"mat = matrix(c(as.character(1:4)), nrow = 2)\ncolnames(mat) = c( 'col1', 'col2' )\nrownames(mat) = c( 'row1', 'row2' )\nmat = apply(mat, 2, function(x) as.numeric(paste(x)))\ncolnames(mat)\nrownames(mat)\n"} {"post_id":38568645,"creation_date":"2016-07-25 13:07:09","snippet":"z_grid <- matrix(, nrow = length(celnum), ncol = length(t2))\n\nrepetitions <- matrix(, nrow = allrepeat, ncol = 1)\n\n\n\nset.seed=20\nfor(i in 1:length(celnum)){\n for (j in 1:length(t2)){\n for (k in 1:allrepeat) {\n results <- samplefunction(celnum[i],t2[j]) \n repetitions[k] <- results\n z_grid[i,j] <- mean(repetitions,na.rm=TRUE) \n } \n }\n}\n\nz_grid\n"} {"post_id":38568645,"creation_date":"2016-07-25 13:07:09","snippet":"set.seed=20\n\nlibrary(foreach)\nlibrary(doSNOW)\n\ncl <- makeCluster(3, type = \"SOCK\")\nregisterDoSNOW(cl)\n\nset.seed=20\noutput <- foreach(i=1:length(celnum),.combine='cbind' ) %:% \n foreach (j=1:length(t2), .combine='c') %:% \n foreach (k = 1:allrepeat) %do% {\n mean(samplefunction(celnum[i],t2[j]) )\n} \noutput\n"} {"post_id":38568291,"creation_date":"2016-07-25 12:51:04","snippet":"table1 <- as.data.frame(table(df1$class))\ncolnames(table1) <- c(\"ID\",\"counts1\")\ntable2 <- as.data.frame(table(df2$class))\ncolnames(table2) <- c(\"ID\",\"counts2\")\ntable3 <- as.data.frame(table(df3$class))\ncolnames(table3) <- c(\"ID\",\"counts3\")\n"} {"post_id":58113748,"creation_date":"2019-09-26 09:33:09","snippet":"library(dplyr)\nlibrary(stringr)\n\nd <- tibble(txt = c(\"i_0000_GES\", \"i_0000_OISO\", \"i_0000_ASE1333\"),\n repl = c(\"1111\", \"1111\", \"2222\"))\n\nstr_sub(d$txt, 3, 6) <- d$repl\nd\n\n# A tibble: 3 x 2\n# txt repl \n# \n# 1 i_1111_GES 1111 \n# 2 i_1111_OISO 1111 \n# 3 i_2222_ASE1333 2222 \n"} {"post_id":38584177,"creation_date":"2016-07-26 07:58:57","snippet":"library(scatterplot3d)\n\nparwd = 7000\nparht = 5000\nparres = 1000\n\npar(oma = c(0,0,0,0), mar = c(0,0,0,0))\n\njpeg(filename=\"CC_1_fo.jpg\", width = parwd, height = parht, res = parres)\nscatterplot3d(1:10, 1:10, 1:10,\n cex.symbol = 0.2,\n xlab = expression(T[1]),\n ylab = expression(T[2]),\n zlab = expression(tau))\ndev.off()\n"} {"post_id":38586938,"creation_date":"2016-07-26 10:08:23","snippet":"suppressMessages(library(reshape2))\nsuppressMessages(library(ggplot2))\nsuppressMessages(library(gridExtra))\n\nCustomer.Code <- c(\"200091\", \"200092\", \"200093\", \"200094\",\"200091\", \"200092\", \"200093\", \"200094\")\nvariable <-c(\"Company.Customer.service\",\"Company.Customer.service\",\"Company.Customer.service\",\"Company.Customer.service\", \"Competitor.Customer.service\", \"Competitor.Customer.service\", \"Competitor.Customer.service\", \"Competitor.Customer.service\")\nvalue <- c(\"5\",\"4\",\"5\",\"5\",\"3\",\"4\",\"4\",\"4\")\n\npmelt <- data.frame(Customer.Code, variable, value, stringsAsFactors=F)\n\npmelt$Status <- ifelse(pmelt$variable %in% c(\"A.E.Customer.service\",\"A.E.Delivery\",\"A.E.Product.Availability\") , \"ANE\" , \"Competitor\")\n\np <- ggplot(pmelt, aes(x = variable, y=value)) + geom_boxplot(aes(colour = Status)) + geom_jitter(width = 0.2) + ggtitle(\"ANE Vs Competitor\") + xlab(\"Aspects\") + ylab(\"Ratings\") + theme(axis.text.x = element_text(face=\"bold\", color=\"#993333\", angle=45), axis.text.y = element_text(face=\"bold\", color=\"#993333\"), title = element_text(face=\"bold\", color=\"#993333\"))\n\ngrid.arrange(arrangeGrob(p))\n"} {"post_id":38587021,"creation_date":"2016-07-26 10:12:21","snippet":"#dependencies\nlibrary(rvest)\nlibrary(dplyr)\nlibrary(pipeR)\nlibrary(stringr)\nlibrary(translateR)\n\n#scrape data from website\nurl <- \"http://irandataportal.syr.edu/election-data\"\nir.pres2014 <- url %>%\n read_html() %>%\n html_nodes(xpath='//*[@id=\"content\"]/div[16]/table') %>%\n html_table(fill = TRUE)\nir.pres2014<-ir.pres2014[[1]]\ncolnames(ir.pres2014)<-c(\"province\",\"Rouhani\",\"Velayati\",\"Jalili\",\"Ghalibaf\",\"Rezai\",\"Gharazi\")\nir.pres2014<-ir.pres2014[-1,]\n\n#Get rid of unnecessary rows\nir.pres2014<-ir.pres2014 %>%\n subset(province!=\"Votes Per Candidate\") %>%\n subset(province!=\"Total Votes\")\n\n#Get rid of commas\nclean_numbers = function (x) str_replace_all(x, '[, ]', '')\nir.pres2014 = ir.pres2014 %>% mutate_each(funs(clean_numbers), -province)\n\n#remove any possible whitespace in string\nno_space = function (x) gsub(\" \",\"\", x)\nir.pres2014 = ir.pres2014 %>% mutate_each(funs(no_space), -province)\n"} {"post_id":58132832,"creation_date":"2019-09-27 10:35:30","snippet":"# Generated by roxygen2: do not edit by hand\n\nexport(coords_rectangle)\nexport(coords_rectangular_lattice)\nexport(coords_segment)\nexport(coords_square)\nexport(display_matrix_int)\nexport(glfw_init)\nexport(lgl_matrix_to_coords_grid_segment)\nexport(lgl_matrix_to_coords_segment)\nexport(palette_for_quads)\n"} {"post_id":38583643,"creation_date":"2016-07-26 07:30:21","snippet":"pb <- tkProgressBar(\"test progress bar\", \"Some information in %\",\n 0, 100, 50)\nSys.sleep(0.5)\nu <- c(0, sort(runif(20, 0 ,100)), 100)\nfor(i in u) {\n Sys.sleep(0.1)\n info <- sprintf(\"%d%% done\", round(i))\n setTkProgressBar(pb, i, sprintf(\"test (%s)\", info), info)\n}\nSys.sleep(5)\nclose(pb)\n"} {"post_id":19576356,"creation_date":"2013-10-24 20:48:53","snippet":"library(stargazer)\nmydata <- read.csv(\"http://www.ats.ucla.edu/stat/data/binary.csv\")\nmydata$rank <- factor(mydata$rank)\nmylogit <- glm(admit ~ gre + gpa + rank, data = mydata, family = \"binomial\")\nsummary(mylogit) \n\n# Table with coefficients\nstargazer(mylogit, ci = T, single.row = T, type = \"text\")\n\n# Table with Odds Ratios, but the CI is not right\nOR.vector <- exp(mylogit$coef)\nstargazer(mylogit, coef = list(OR.vector), ci = T, single.row = T, type = \"text\")\n\n# Correct CIs\nCI.vector <- exp(confint(mylogit))\ncbind(OR = OR.vector, CI.vector)\n"} {"post_id":19597643,"creation_date":"2013-10-25 19:08:05","snippet":"mytheme <- trellis.par.get()\nmytheme$strip.border$col = 'grey80'\nmytheme$strip.background$col = 'grey80'\nmytheme$axis.line$col = 'grey80'\nmytheme$axis.text$col = 'grey60'\nmytheme$plot.symbol$pch = 20\nmytheme$plot.symbol$cex = .5\nmytheme$plot.symbol$col = '#7AC5CD'\nmytheme$plot.symbol$alpha = .8\n\nl.sc <- update(scatter.lattice, par.settings = mytheme,\n layout = c(3, 2),\n between = list(x = 0.3, y = 0.3))\nprint(l.sc)\n"} {"post_id":19599865,"creation_date":"2013-10-25 21:42:08","snippet":"set.seed(600)\nx <- rgamma(500,shape=8,scale=0.1)\nmean(x)\nhist(x,prob=T,main='Gamma,scale=0.1')\nlines(density(x),col='red',lwd=2)\n"} {"post_id":58166155,"creation_date":"2019-09-30 10:37:09","snippet":"library(ggplot2)\nlibrary(minpack.lm)\n\ndataset <- read.table(text='\n x y\n 1 0.1 1\n 2 30 0.3\n 3 1000 0', header=T)\n\nds <- data.frame(dataset)\nstr(ds)\nplot(ds, main = \"bla\")\nnlmInitial <- c(a = 0.5, power1 = -0.2, b = -0.02, power2 = 0.3)\nm <- nlsLM(y ~ a*I(x^power1) + b*I(x^power2), \n data = ds, \n start = nlmInitial, \n trace = T)\nsummary(m)$coefficients\n"} {"post_id":19596820,"creation_date":"2013-10-25 18:17:00","snippet":"library(snow)\ncl2 <- makeCluster(3, type = \"SOCK\")\ndata <- rep(1:10000,10000)\n\nclusterExport(cl2,\"data\")\n\n# is remove neccssary?\nclusterEvalQ(cl2, rm( data, pos=globalenv() ) ) \n\nstopCluster(cl2) \n"} {"post_id":58147450,"creation_date":"2019-09-28 14:50:43","snippet":"library(caret)\nlibrary(tidyverse)\nlibrary(magrittr)\nlibrary(mlbench)\n\ndata(BostonHousing)\n\nseed <- 171\n\n# shuffled <- TRUE\nshuffled <- FALSE\n\nif (shuffled) {\n dataset <- BostonHousing %>% nrow %>% sample %>% BostonHousing[., ]\n} else {\n dataset <- BostonHousing %>% as_tibble()\n}\n\ntarget_label <- \"medv\"\nfeatures_labels <- dataset %>% select_if(is.numeric) %>%\n select(-target_label) %>% names %T>% print\n\n# define ml algorithms to train\nalgorithm_list <- c(\n \"lm\"\n , \"glmnet\"\n , \"knn\"\n , \"gbm\"\n , \"rf\"\n)\n\n# repeated cv\ntraining_configuration <- trainControl(\n method = \"repeatedcv\", number = 10\n , repeats = 10\n , savePredictions = \"final\",\n # , returnResamp = \"all\"\n)\n\n# preprocess by standardization within each k-fold\npreprocess_configuration = c(\"center\", \"scale\")\n\n# select variables\ndataset %<>% select(target_label, features_labels) %>% na.omit\n\n# dataset subsetting for tibble: [[\nset.seed(seed)\ntraining.index <- createDataPartition(dataset[[target_label]], p = 0.8, list = FALSE)\ntraining.set <- dataset[training.index, ]\ntesting.set <- testing.set <- dataset[-training.index, ]\n\n########################################\n# 3.2: Select the target & features\n########################################\ntarget <- training.set[[target_label]]\nfeatures <- training.set %>% select(features_labels) %>% as.data.frame\n\n########################################\n# 3.3: Train the models\n########################################\nmodels.list <- list()\n\nmodels.list <- algorithm_list %>%\n\n map(function(algorithm_label) {\n model <- train(\n x = features,\n y = target,\n method = algorithm_label,\n preProcess = preprocess_configuration,\n trControl = training_configuration\n )\n return(model)\n }\n ) %>%\n setNames(algorithm_list)\n"} {"post_id":38625642,"creation_date":"2016-07-28 01:18:23","snippet":"#Simulate Data\n\nX = data.frame(\n group = rep(paste0(\"NO\",1:10000),each=2),\n flag = sample(c(\"F\",\"P\"),20000,replace = TRUE),\n var = rnorm(20000)\n)\n\n\n\nlibrary(plyr)\nlibrary(dplyr)\n\n#plyr\n\nSTART = proc.time()\nX2 = ddply(X,.(flag),function(df) {\n if( sum(df$flag==\"F\")> 0){\n R = df[df$flag==\"F\",]\n if(nrow(R)>1) {R = R[1,]} else {R = R}\n } else{\n R = df[1,]\n }\n R\n})\nproc.time() - START \n\n#user system elapsed \n#0.03 0.00 0.03 \n\n#dplyr method 1\n\nSTART = proc.time()\nX %>%\n group_by(group) %>% \n slice(which.min(flag))\nproc.time() - START \n\n#user system elapsed \n#0.22 0.02 0.23 \n\n#dplyr method 2\n\nSTART = proc.time()\nX %>%\n group_by(group, flag) %>%\n slice(1) %>%\n group_by(group) %>% \n slice(which.min(flag))\nproc.time() - START \n\n#user system elapsed \n#0.28 0.00 0.28 \n"} {"post_id":58151063,"creation_date":"2019-09-28 23:33:43","snippet":"library(dslabs)\nlibrary(dplyr)\nlibrary(lubridate)\n\ndata(\"reported_heights\")\n\ndat <- mutate(reported_heights, date_time = ymd_hms(time_stamp)) %>%\n filter(date_time >= make_date(2016, 01, 25) & date_time < make_date(2016, 02, 1)) %>%\n mutate(type = ifelse(day(date_time) == 25 & hour(date_time) == 8 & between(minute(date_time), 15, 30), \"inclass\",\"online\")) %>%\n select(sex, type, time_stamp)\n\ny <- factor(dat$sex, c(\"Female\", \"Male\"))\nx <- dat$type\n\ncounter <- count(dat, sex,type)\n"} {"post_id":58167848,"creation_date":"2019-09-30 12:23:27","snippet":"library(tesseract)\nlibrary(dplyr)\nlibrary(stringr)\nlibrary(pdftools)\nlibrary(readr)\nlibrary(magick)\n\n"} {"post_id":38625493,"creation_date":"2016-07-28 00:58:49","snippet":"require(RCurl)\nrequire(prettyR)\nlibrary(caret)\nurl <- \"https://raw.githubusercontent.com/gastonstat/CreditScoring/master/CleanCreditScoring.csv\"\ncs_data <- getURL(url)\ncs_data <- read.csv(textConnection(cs_data))\nclasses <- cs_data[, \"Status\"]\npredictors <- cs_data[, -match(c(\"Status\", \"Seniority\", \"Time\", \"Age\", \"Expenses\", \n \"Income\", \"Assets\", \"Debt\", \"Amount\", \"Price\", \"Finrat\", \"Savings\"), colnames(cs_data))]\n\ntrain_set <- createDataPartition(classes, p = 0.8, list = FALSE)\nset.seed(123)\n\ncs_data_train = cs_data[train_set, ]\ncs_data_test = cs_data[-train_set, ]\n\n# Define the tuned parameter\ngrid <- expand.grid(mtry = seq(4,16,4), ntree = c(700, 1000,2000) )\n\nctrl <- trainControl(method = \"cv\", number = 10, summaryFunction = twoClassSummary,classProbs = TRUE)\n\nrf_fit <- train(Status ~ ., data = cs_data_train,\n method = \"rf\",\n preProcess = c(\"center\", \"scale\"),\n tuneGrid = grid,\n trControl = ctrl, \n family= \"binomial\",\n metric= \"ROC\" #define which metric to optimize metric='RMSE'\n )\nrf_fit\n"} {"post_id":38643809,"creation_date":"2016-07-28 18:09:12","snippet":"library(class)\ndata <- data.frame(\"class_variable\"=sample(LETTERS[1:2], 30, replace = TRUE),\n \"predictor_1\" = runif(30),\n \"predictor_2\" = runif(30))\ntrain <- data[1:20,]\ntest <- data[21:30,]\n\ntest$class_variable <- NA\n\nknn(train, test, train$class_variable)\n"} {"post_id":38645018,"creation_date":"2016-07-28 19:19:44","snippet":"library(plyr)\nlibrary(dplyr)\nlibrary(openxlsx)\n\ndf <- iris\n\n# Analysis 1\nresults1 <- df %>%\n group_by(Species) %>%\n summarise(count = n())\n\n# Analysis 2\nresults2 <- df %>%\n group_by(Species) %>%\n summarise(mean.sl = mean(Sepal.Length),\n mean.sw = mean(Sepal.Width))\n"} {"post_id":38645044,"creation_date":"2016-07-28 19:21:05","snippet":" set.seed(1)\n x<-matrix(rnorm(500),nrow=100,ncol=5)\n y<-rnorm(100)\n rollapply(x,width=5,FUN= function(x) {cov(x,y)})\n z<-cbind(x,y)\n rollapply(z,width=5, FUN=function(x){cov(z,z[,6])})\n"} {"post_id":19621512,"creation_date":"2013-10-27 18:09:10","snippet":"require(ggplot2)\nrequire(grid)\n# pdf(\"a.pdf\")\npng('a.png')\na <- qplot(date, unemploy, data = economics, geom = \"line\") + opts(title='A')\nb <- qplot(uempmed, unemploy, data = economics) + geom_smooth(se = F) + opts(title='B')\nc <- qplot(uempmed, unemploy, data = economics, geom=\"path\") + opts(title='C')\ngrid.newpage()\npushViewport(viewport(layout = grid.layout(2, 2)))\nvplayout <- function(x, y) viewport(layout.pos.row = x, layout.pos.col = y)\nprint(a, vp = vplayout(1, 1:2))\nprint(b, vp = vplayout(2, 1))\nprint(c, vp = vplayout(2, 2))\ndev.off()\n"} {"post_id":19622063,"creation_date":"2013-10-27 18:55:07","snippet":"library (ggplot2)\n\npng (filename = \"graph.png\")\nstats <- read.table(\"processed-r.dat\", header=T, sep=\",\")\nattach (stats)\nstats <- stats[order(best), ]\nsp <- stats$A / stats$B\nindex <- seq (1, sum (sp >= 1.0))\nstats <- data.frame (x=index, y=sp[sp>=1.0])\nggplot (data=stats, aes (x=x, y=y, group=1)) + geom_line()\ndev.off ()\n"} {"post_id":38667194,"creation_date":"2016-07-29 20:44:50","snippet":"cq = c(15.5193589369923,15.6082097993496,15.3048276641115,15.887944383963,15.3813224284544,14.9723432922121,14.8742353464212,15.0448020475332,15.1584221729435,15.3692219904727,15.2369219681739,15.0804950645883,15.0836397511495,14.8821059462034,14.6827696388115,14.5701385743889,14.8506248103639,14.8475325690146,14.7377458445001,14.6258765734272,15.3585770134881,15.2994209401567,15.5178103826596,15.2411668198437,15.3413307248142,15.3645926457095,15.2241340874265,15.7516405898009,15.7683360263607,15.5852354340738,14.7451372367313,14.650625258402,14.7596201108925,15.0504977144055,15.0178091754821,15.100874342289,14.5156700740607,15.0530667717479,14.754595621435,15.5879633065185,15.3449828894141,15.3112460363113,15.232600495493,15.4378070492087,15.1621663266126,16.0120124580213,16.2104534293435,16.2765899877946,17.1446379330444,17.1717364140053,17.0155350105157,15.5218922723681,15.4543443324508,15.5282690363252,15.0202919978723,15.0410524376083,15.1169661551775,15.335220483258,15.3191814464955,15.0679651604846,14.7270263787123,14.70717761566,14.7907442084919,15.8468089268423,15.6714073529734,15.5478017041242,14.6949593095613,14.7537769900696,14.830942214569,15.0820225358985,15.3454125813989,15.304399073517,15.4159319040107,16.1250033895004,15.5359407225865,15.3251900155103,15.1571914994646,15.412721442436,15.913112918988,15.9852823695227,16.0912887332562,15.4897399161851,15.0710262650299,15.3517226832146,17.0001128578501,17.1040579605654,16.9578316599788,15.8842918497549,15.7016383123704,15.8513519332371,16.9420990886101,17.0793832045434,16.9288868492911,14.9127628979216,14.7689529893246,15.0534122173222,15.3185448628303,15.5507864243439,15.3737185073511,15.4350799532271,15.2414612478027,15.361320770232,15.7401140808761,15.8582795450189,15.7634036480016,15.5797995263497,15.9126261329496,15.9256641722586,15.1308493265056,15.2450158090279,15.0699176510971,15.0368959001792,14.8828877909216,14.8852035927172,15.8253506435753,15.8938440960183,15.888311876759,15.4872886586516,15.5492199156675,15.7313291529313,16.5365758222542,16.8386981731158,16.7239280992675,15.9356391540897,15.7383049532238,15.9409000309973,15.2005952554035,15.0390142751348,15.154888655127,14.6373767323354,14.3087397097081,14.3970067065903,14.6453627024929,14.8109205614192,14.6266778290643,15.5170574352528,15.359943766027,15.5869322081508,15.5246550838727,15.4670382654415,15.4211907882731,16.9534561402918,17.4848334482537,17.3182067272327,15.7804318020053,15.86794322314,15.6532944587946,16.543432367992,16.6848617423114,16.8344939905775,15.5212254647114,15.8348559815603,15.6592827767612,15.3027400892518,15.5498124465958,15.8362202772445,14.8415823671167,15.7307379811374,14.8529575353737,16.6466266958983,16.1687733596343,16.0342973266029,14.5976161739123,14.776507726931,14.6780484406283,15.3927619991024,15.3106866267163,15.2920260038624,15.9666798099925,16.2595244266754,16.1035265916681,16.018233002759,15.8460056716414,16.0722176294152,16.2763177549617,16.364250121284,16.2995041975045,16.3975912697976,16.182759197402,16.1164022801451,16.5026752161837,16.2401540005223,16.3715573563274,18.4119769797938,18.1208386122385,18.0068316479116,17.1455993749728,17.0558275544137,16.9150038143768)\nsample = c(\"CD4 LM\",\"CD4 LM\",\"CD4 JC\",\"CD4 JC\",\"CD4 JC\",\"CD4 BM\",\"CD4 BM\",\"CD4 BM\",\"CD4 MC\",\"CD4 MC\",\"CD4 MC\",\"CD4 TM\",\"CD4 TM\",\"CD4 TM\",\"CD4 MM\",\"CD4 MM\",\"CD4 MM\",\"CD4 SRits\",\"CD4 SRits\",\"CD4 SRits\",\"CD4 GV\",\"CD4 GV\",\"CD4 GV\",\"CD4 WW\",\"CD4 WW\",\"CD4 WW\",\"CD4 CH\",\"CD4 CH\",\"CD4 FJ\",\"CD4 FJ\",\"CD4 KS\",\"CD4 KS\",\"CD4 KS\",\"CD4 NG\",\"CD4 NG\",\"CD4 NG\",\"CD4 CG\",\"CD4 CG\",\"CD4 CG\",\"CD4 CSR\",\"CD4 CSR\",\"CD4 CSR\",\"CD4 JM\",\"CD4 JM\",\"CD4 JM\",\"CD4 DF\",\"CD4 DF\",\"CD4 DF\",\"CD4 AM\",\"CD4 AM\",\"CD4 AM\",\"CD4 BP\",\"CD4 BP\",\"CD4 BP\",\"CD4 ER\",\"CD4 ER\",\"CD4 ER\",\"CD4 SRusse\",\"CD4 SRusse\",\"CD4 SRusse\",\"CD4 DS\",\"CD4 DS\",\"CD4 DS\",\"CD4 KJ\",\"CD4 KJ\",\"CD4 KJ\",\"CD4 GD\",\"CD4 GD\",\"CD4 GD\",\"CD4 KG\",\"CD4 KG\",\"CD4 KG\",\"CD4 KR\",\"CD4 KR\",\"CD4 KR\",\"CD4 FN\",\"CD4 FN\",\"CD4 FN\",\"CD4 RM\",\"CD4 RM\",\"CD4 RM\",\"CD4 LA\",\"CD4 LA\",\"CD4 LA\",\"CD4 EC\",\"CD4 EC\",\"CD4 EC\",\"CD4 KW\",\"CD4 KW\",\"CD4 KW\",\"CD4 HB\",\"CD4 HB\",\"CD4 HB\",\"CD8 LM\",\"CD8 LM\",\"CD8 LM\",\"CD8 JC\",\"CD8 JC\",\"CD8 JC\",\"CD8 BM\",\"CD8 BM\",\"CD8 BM\",\"CD8 MC\",\"CD8 MC\",\"CD8 MC\",\"CD8 TM\",\"CD8 TM\",\"CD8 TM\",\"CD8 MM\",\"CD8 MM\",\"CD8 MM\",\"CD8 SRits\",\"CD8 SRits\",\"CD8 SRits\",\"CD8 GV\",\"CD8 GV\",\"CD8 GV\",\"CD8 WW\",\"CD8 WW\",\"CD8 WW\",\"CD8 CH\",\"CD8 CH\",\"CD8 CH\",\"CD8 FJ\",\"CD8 FJ\",\"CD8 FJ\",\"CD8 KS\",\"CD8 KS\",\"CD8 KS\",\"CD8 NG\",\"CD8 NG\",\"CD8 NG\",\"CD8 CG\",\"CD8 CG\",\"CD8 CG\",\"CD8 CSR\",\"CD8 CSR\",\"CD8 CSR\",\"CD8 JM\",\"CD8 JM\",\"CD8 JM\",\"CD8 DF\",\"CD8 DF\",\"CD8 DF\",\"CD8 AM\",\"CD8 AM\",\"CD8 AM\",\"CD8 BP\",\"CD8 BP\",\"CD8 BP\",\"CD8 ER\",\"CD8 ER\",\"CD8 ER\",\"CD8 SRusse\",\"CD8 SRusse\",\"CD8 SRusse\",\"CD8 DS\",\"CD8 DS\",\"CD8 DS\",\"CD8 KJ\",\"CD8 KJ\",\"CD8 KJ\",\"CD8 GD\",\"CD8 GD\",\"CD8 GD\",\"CD8 KG\",\"CD8 KG\",\"CD8 KG\",\"CD8 KR\",\"CD8 KR\",\"CD8 KR\",\"CD8 FN\",\"CD8 FN\",\"CD8 FN\",\"CD8 RM\",\"CD8 RM\",\"CD8 RM\",\"CD8 LA\",\"CD8 LA\",\"CD8 LA\",\"CD8 EC\",\"CD8 EC\",\"CD8 EC\",\"CD8 KW\",\"CD8 KW\",\"CD8 KW\",\"CD8 HB\",\"CD8 HB\",\"CD8 HB\")\ndf = data.frame(cq, sample)\n\ndf.res <- lm(cq~sample, data = df)\nrequire(lsmeans)\nt<- pairs(lsmeans(df.res, \"sample\"))\nsystem.time(tc <- confint(t, level=0.95))\n"} {"post_id":38665022,"creation_date":"2016-07-29 18:07:08","snippet":" library(dplyr)\nactual=c(1,1,1,0,0,1,1,0,0,1)\nprob=c(0.8,0.8,0.2,0.1,0.6,0.7,0.8,0.9,0.7,0.9)\nn=1:10\nfor_chart=data.frame(actual,prob,n)\nfor_chart=for_chart[with(for_chart, order(-prob)),]\nfor_chart$decile <- cut(n, breaks = quantile(n, probs = seq(0, 1, 0.1)), \n labels = 1:10, include.lowest = TRUE)\n"} {"post_id":19643973,"creation_date":"2013-10-28 19:59:10","snippet":"my.data <- read.table(text= \"\n r1 r2 r3 t1 t2 t3 v1 v2 v3 v4 v5 v6\n 1 0 0 10 20 30 1 0 0 0 0 0\n 1 0 0 10 20 30 1 1 0 0 0 0\n 1 0 0 10 20 30 1 0 1 0 0 0\n 1 0 0 10 20 30 1 0 1 1 0 0\n 1 0 0 10 20 30 0 0 0 0 0 0\n\n 0 1 0 10 20 30 0 1 1 1 1 1\n 0 1 0 10 20 30 0 0 1 1 1 1\n 0 1 0 10 20 30 0 0 0 1 1 1\n 0 1 0 10 20 30 0 0 0 0 1 1\n 0 1 0 10 20 30 0 0 0 0 0 1\n\n 0 0 1 10 20 30 1 1 1 1 1 1\n 0 0 1 10 20 30 1 0 1 1 1 1\n 0 0 1 10 20 30 1 0 0 1 1 1\n 0 0 1 10 20 30 1 0 0 0 1 1\n 0 0 1 10 20 30 1 0 0 0 0 1\n\", header=TRUE, na.strings=NA)\n\nmy.data$my.group <- which(my.data[,1:3]==1, arr.ind=TRUE)[,2]\nmy.data\n\nmy.sums <- t(sapply(split(my.data[,7:(ncol(my.data)-1)], my.data$my.group), function(i) sapply(seq(2, ncol(i), 2), function(j) sum(i[,c((j-1),j)], na.rm=TRUE))))\nmy.sums\n\n# [,1] [,2] [,3]\n# 1 5 3 0\n# 2 1 5 9\n# 3 6 5 9\n"} {"post_id":19666965,"creation_date":"2013-10-29 19:02:38","snippet":"x <- (\"Hello my name is Christopher. Some people call me Chris\")\ny <- (\"Chris is an interesting person to be around\")\nz <- (\"Because he plays sports and likes statistics\")\n\nlll <- tolower(list(x,y,z))\ndict <- tolower(c(\"Chris\", \"Hell\"))\n\nmmm <- matrix(nrow=length(lll), ncol=length(dict), NA)\n\nfor (i in 1:length(lll)) {\nfor (j in 1:length(dict)) {\n mmm[i,j] <- sum(grepl(dict[j],lll[i]))\n}\n}\nmmm\n"} {"post_id":19667980,"creation_date":"2013-10-29 20:02:04","snippet":"set.seed(12345)\nN=100\nNDRAWS=100000\ndf <- data.frame(alpha=sample(1:20, N, replace=T), beta=sample(1:200, N, replace=T)) \n\nvec <- vector(mode = \"integer\", length = N )\n\nfor(i in 1:NDRAWS){\n # order probabilities after a single draw for every theta\n pos <- order(rbeta(N, shape1=df$alpha, shape2=df$beta) )\n\n # sum up winning positions for every theta\n vec[pos] <- vec[pos] + 1:N\n}\n\n# order thetas\nord <- order(-vec)\n\ndf[ord,]\n"} {"post_id":19693835,"creation_date":"2013-10-30 21:08:45","snippet":"cl <- makeCluster(3, type = \"SOCK\",outfile=\"log.txt\") \n\nabc <<- 123\n\nclusterExport(cl,\"abc\")\n\nclusterApplyLB(cl, 1:6, \n function(y){\n print(paste(\"before:\",abc));\n abc<<-y;\n print(paste(\"after:\",abc));\n }\n)\nstopCluster(cl)\n"} {"post_id":38713809,"creation_date":"2016-08-02 07:05:52","snippet":"library(leaflet)\nlibrary(shiny)\n\nHeight = 1000 \napp = shinyApp(\n ui = fluidPage(\n sidebarLayout(\n sidebarPanel( sliderInput(\"Height\",\n \"Height in Pixels:\",\n min = 100,\n max = 2000,\n value = 500)\n ),\n mainPanel(\n leafletOutput('myMap', width = \"200%\", height = Height)\n )\n )\n ),\n server = function(input, output) {\n Height <- reactive(input$Height)\n map = leaflet() %>% addTiles() %>% setView(-93.65, 42.0285, zoom = 17)\n output$myMap = renderLeaflet(map)\n }\n)\n\nif (interactive()) print(app)\n"} {"post_id":58251325,"creation_date":"2019-10-05 18:48:30","snippet":"require(RCurl)\nrequire(ncdf4)\n\nurl <- \"https://oceandata.sci.gsfc.nasa.gov/MODIS-Aqua/Mapped/Seasonal_Climatology/4km/sst/\"\nfilename <-\"A20021722014263.L3m_SCSU_NSST_sst_4km.nc\"\n\ndownload.file(paste0(url, filename),destfile = paste0(\"~/Desktop/\", filename), method=\"curl\")\n\nsetwd(\"~/Desktop/\")\nfiles<-dir(pattern=\"*.nc\")\nf<-nc_open(files[1])\n"} {"post_id":19721824,"creation_date":"2013-11-01 06:21:59","snippet":"m = matrix(0, 10, 5, dimnames = list(c(\"A\", \"B\", \"C\", \"D\", \"E\", \"F\", \"G\", \"H\", \"I\", \"J\"), c(1, 2, 3, 4, 5)))\nm[1,] = c(0,0,0,0,1)\nm[2,] = c(0,0,0,1,1)\nm[3,] = c(0,0,1,1,1)\nm[4,] = c(0,0,1,1,0)\nm[5,] = c(1,0,0,0,0)\nm[6,] = c(1,1,1,0,0)\nm[7,] = c(0,1,1,0,0)\nm[8,] = c(0,1,1,0,0)\nm[9,] = c(0,1,1,1,0)\nm[10,] = c(1,1,1,0,1)\n# Generates row and column dendrograms.\nhr <- hclust(as.dist(1-cor(t(m), method=\"pearson\")), method=\"ward\"); \nhc <- hclust(as.dist(1-cor(m, method=\"spearman\")), method=\"ward\")\n"} {"post_id":19721824,"creation_date":"2013-11-01 06:21:59","snippet":"library(gplots)\nmycl <- cutree(hr, 2); \nmycolhc <- rainbow(length(unique(mycl)), start=0.1, end=0.9); \nmycolhc <- mycolhc[as.vector(mycl)]\nmyheatcol <- redgreen(75)\n\n# Creates heatmap for entire data set\nheatmap.2(\n m, \n Rowv=as.dendrogram(hr), \n Colv=as.dendrogram(hc), \n col=myheatcol, \n scale=\"row\", \n density.info=\"none\", \n trace=\"none\", \n RowSideColors=mycolhc, \n cexCol=0.6, \n labRow=NA\n )\n"} {"post_id":38741997,"creation_date":"2016-08-03 11:14:45","snippet":"library(\"tree\")\ncredit<-read.csv(\"C:/Users/Administrator/Desktop/german_credit (2).csv\")\n\nlibrary(\"caret\")\nset.seed(1000)\n\nintrain<-createDataPartition(y=credit$Creditability,p=0.7,list=FALSE)\ntrain<-credit[intrain, ]\ntest<-credit[-intrain, ]\n\ntreemod<-tree(Creditability~. , data=train)\nplot(treemod)\ntext(treemod)\n\ncv.trees<-cv.tree(treemod,FUN=prune.tree)\nplot(cv.trees)\n\nprune.trees<-prune.tree(treemod,best=3)\nplot(prune.trees)\ntext(prune.trees,pretty=0)\n\ninstall.packages(\"e1071\")\nlibrary(\"e1071\")\ntreepred<-predict(prune.trees, newdata=test)\n\nconfusionMatrix(treepred, test$Creditability)\n"} {"post_id":58277174,"creation_date":"2019-10-07 21:08:01","snippet":"library(shiny)\nlibrary(shinyglide)\n\nui <- fixedPage(\n titlePanel(\"shinyglide modal example\"),\n sidebarLayout(\n sidebarPanel(\n p('Hello World')\n ),\n mainPanel()\n )\n )\n\nserver <- function(input, output, session) {\n\n modal_controls <- glideControls(\n\n list(prevButton(),\n firstButton(class = \"btn btn-danger\",`data-dismiss`=\"modal\",\"No, thanks !\")),\n\n list(nextButton(),\n lastButton(class = \"btn btn-success\",`data-dismiss`=\"modal\",\"Done\"))\n\n )\n\n glide_modal <- modalDialog(\n\n title = \"Startup assistant\",easyClose = FALSE,footer = NULL,\n\n glide(custom_controls = modal_controls,\n\n screen(next_condition=\"input.options.length > 0\",\n p(\"First, please select an option\"),\n checkboxGroupInput(\"options\", \"Options\", choices=c('a','b','c'),selected=NULL)\n ),\n\n screen(p(\"Next, please select a number\"),\n numericInput(\"number\", \"Number\", value = 1, min = 0)\n ),\n\n screen(p(\"Thanks, we're all set !\"))\n\n )\n\n )\n\n showModal(glide_modal)\n\n}\n\nshinyApp(ui, server)\n"} {"post_id":38766155,"creation_date":"2016-08-04 11:30:14","snippet":"ID <- c(\"480\", \"480\", \"620\", \"620\",\"712\",\"712\")\nYear <- c(\"0\", \"1\", \"0\", \"1\",\"0\", \"1\")\nPlot <- c(\"14\", \"14\", \"13\", \"13\",\"20\",\"20\")\nTreat <- c(\"0\", \"0\", \"0\", \"1\", \"0\", \"1\")\nExp <- c(\"31\", \"43\", \"44\", \"36\", \"29\", \"71\")\nExpSqrt <- c(\"5.567764\", \"6.557439\", \"6.633250\", \"6.000000\", \"5.385165\", \"8.426150\")\n\nWinter <- data.frame(ID, Year, Plot, Treat,\n Exp, ExpSqrt,\n stringsAsFactors = TRUE) \n"} {"post_id":38768398,"creation_date":"2016-08-04 13:14:41","snippet":"result = 0\n\n#iteration 1\ni = 1\nresult = result + i\nlog(\"a\")\nresult = result + i\n\n#iteration 2\ni = i+1\nresult = result + i\nlog(\"a\")\nresult = result + i\n\n#iteration 3\ni = i+1\nresult = result + i\nlog(\"a\")\nresult = result + i\n\n#etc.\n"} {"post_id":38768499,"creation_date":"2016-08-04 13:19:10","snippet":"library(text2vec)\nlibrary(caret)\ndata(\"movie_review\")\ntrain = movie_review[1:4000, ]\ntest = movie_review[4001:5000, ]\n\nit <- itoken(train$review, preprocess_function = tolower, tokenizer = word_tokenizer)\nvocab <- create_vocabulary(it, stopwords = tokenizers::stopwords())\npruned_vocab <- prune_vocabulary(vocab, term_count_min = 10, doc_proportion_max = 0.5, doc_proportion_min = 0.001)\n\nvectorizer <- vocab_vectorizer(pruned_vocab)\nit = itoken(train$review, tokenizer = word_tokenizer, ids = train$id)\ndtm_train = create_dtm(it, vectorizer)\nit = itoken(test$review, tokenizer = word_tokenizer, ids = test$id)\ndtm_test = create_dtm(it, vectorizer)\n\nctrl.svm.1 <- trainControl(method=\"repeatedcv\",\n number=10,\n repeats=5,\n summaryFunction = multiClassSummary,\n verboseIter = TRUE)\n\nfit.svm.1 <- train(x = dtm_train, y= as.factor(train$sentiment), \n method=\"svmLinear2\", \n metric=\"Accuracy\", \n trControl = ctrl.svm.1, \n scale = FALSE, verbose = TRUE)\n"} {"post_id":19778240,"creation_date":"2013-11-04 22:12:08","snippet":"# define the similarity function\ncosineSim <- function(x){\n as.matrix(x%*%t(x)/(sqrt(rowSums(x^2) %*% t(rowSums(x^2))))) \n}\n\n# define some feature vectors\nA <- c(1,1,0,0.5)\nB <- c(1,1,0,0.5)\nC <- c(1,1,0,1.2)\nD <- c(1,0,0,0.7)\n\ndataTest <- data.frame(A,B,C,D)\ndataTest <- data.frame(t(dataTest))\ndataMatrix <- as.matrix(dataTest)\n\n# get similarity matrix\ncosineSim(dataMatrix)\n"} {"post_id":58302449,"creation_date":"2019-10-09 10:48:23","snippet":"##generel info;\nmemory.size(max=TRUE)\n# [1] 11418.75\nsessionInfo()\n# R version 3.6.1 (2019-07-05)\n# Platform: x86_64-w64-mingw32/x64 (64-bit)\n# Running under: Windows 10 x64 (build 18362)\n\n##install packages, load librarys\n# install.packages(c(\"quanteda\", \"devtools\"))\n# devtools::install_github(\"quanteda/quanteda.corpora\")\nlibrary(\"quanteda\")\nlibrary(RJSONIO)\nlibrary(data.table)\nlibrary(jsonlite)\nlibrary(dplyr)\nlibrary(glmnet)\n\n##load data, convert to a dataframe, convert to a dfm\n\nbaseurl <- \"https://raw.githubusercontent.com/alexlitel/congresstweets/master/data/\"\nd0 <- fromJSON(paste0(baseurl, \"2019-10-07.json\"), flatten = TRUE)\nd1 <- fromJSON(paste0(baseurl, \"2019-10-06.json\"), flatten = TRUE)\nd2 <- fromJSON(paste0(baseurl, \"2019-10-05.json\"), flatten = TRUE)\nd3 <- fromJSON(paste0(baseurl, \"2019-10-04.json\"), flatten = TRUE)\nd4 <- fromJSON(paste0(baseurl, \"2019-10-03.json\"), flatten = TRUE)\nd5 <- fromJSON(paste0(baseurl, \"2019-10-02.json\"), flatten = TRUE)\nd6 <- fromJSON(paste0(baseurl, \"2019-10-01.json\"), flatten = TRUE)\nd7 <- fromJSON(paste0(baseurl, \"2019-09-30.json\"), flatten = TRUE)\nd8 <- fromJSON(paste0(baseurl, \"2019-09-29.json\"), flatten = TRUE)\nd9 <- fromJSON(paste0(baseurl, \"2019-09-28.json\"), flatten = TRUE)\nd10 <- fromJSON(paste0(baseurl, \"2019-09-27.json\"), flatten = TRUE)\nd11 <- fromJSON(paste0(baseurl, \"2019-09-26.json\"), flatten = TRUE)\nd12 <- fromJSON(paste0(baseurl, \"2019-09-25.json\"), flatten = TRUE)\n\nd <- rbind(d0,d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12)\n\nrm(d0,d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12)\n\nd$text <- as.character(d$text)\n\ndfm <-dfm((corpus(select(d, id, text))), remove_punct=TRUE, remove=c( stopwords(\"english\"), \"t.co\", \"https\", \"rt\", \"amp\", \"http\", \"t.c\", \"can\"))\n\ndfm_df <- convert(dfm, to= 'data.frame')\n\n#Error in asMethod(object) : \n #Cholmod error 'problem too large' at file ../Core/cholmod_dense.c, line 105\n\n"} {"post_id":58302449,"creation_date":"2019-10-09 10:48:23","snippet":"\nd_t <- d[c(1:2000), (1:7)]\n\n##code control variable\n\n#url\n\nd_t$url<- as.integer(ifelse(grepl(\"://\", d_t$text), \"1\", \"0\"))\n\n#source used\nd_t$source_grp[grepl(\"Twitter for Android\", d_t$source)] <- \"Twitter for Android\"\nd_t$source_grp[grepl(\"Twitter Web Client\", d_t$source)] <- \"Twitter Web Client\"\nd_t$source_grp[grepl(\"Twitter for iPhone\", d_t$source)] <- \"Twitter for iPhone\"\nd_t$source_grp[grepl(\"Twitter for Windows\", d_t$source)] <- \"Twitter for Windows\"\nd_t$source_grp[grepl(\"Twitter for Samsung Tablets\", d_t$source)] <- \"Samsung Tablets\"\nd_t$source_grp[grepl(\"Twitter for Android Tablets\", d_t$source)] <- \"Android Tablets\"\nd_t$source_grp[grepl(\"Twitter for Windows Phone\", d_t$source)] <- \"Windows Phone\"\nd_t$source_grp[grepl(\"Twitter for BlackBerry\", d_t$source)] <- \"BlackBerry\"\nd_t$source_grp[grepl(\"Twitter for iPad\", d_t$source)] <- \"Twitter for iPad\"\nd_t$source_grp[grepl(\"Twitter for Mac\", d_t$source)] <- \"Twitter for Mac\"\nd_t$source_grp[is.na(d_t$source_grp)] <- \"Other\" \n\n#retweet\n\nd_t$retweet <- ifelse(grepl(\"RT @\", d_t$text), \"1\", \"0\") #create a variable that takes the value 1 when it is a RT\n\n##create a x and y matrix\n\nx= model.matrix ( retweet~., cbind(select(d_t, retweet, source_grp, url), convert(dfm((corpus(select(d_t, id, text))), remove_punct=TRUE, remove=c( stopwords(\"english\"), \"t.co\", \"https\", \"rt\", \"amp\", \"http\", \"t.c\", \"can\")), to=\"data.frame\")) )[,-1]\n\ny=d_t$retweet\n\nlasso <- cv.glmnet(x=x, y=y, alpha=1, nfolds=5, family=\"binomial\")\n\n\n"} {"post_id":19778612,"creation_date":"2013-11-04 22:36:10","snippet":"p <- ggplot(df, aes(y=id))\np <- p + scale_colour_manual(name=\"\", values =c(\"value3\"=\"grey\", \"value2\"=\"black\"))\np <- p + geom_point(aes(x=value3, colour ='value3'), size=3)\np <- p + geom_point(aes(x=value2, colour ='value2'), size=5)\np\n"} {"post_id":58302309,"creation_date":"2019-10-09 10:40:39","snippet":"library(data.table)\nlibrary(xgboost)\n\n# Generate test data\ngenerate_test_data <- function(n_rows = 1e5, feature_count = 5, train_fraction = 0.5){\n\n # Make targets\n test_data <- data.table(\n target = sign(runif(n = n_rows, min=-1, max=1))\n )\n\n # Add feature columns.These are normally distributed and shifted by the target\n # in order to create a noisy signal\n for(feature in 1:feature_count){\n\n # Randomly create features of the noise\n mu <- runif(1, min=-1, max=1)\n sdev <- runif(1, min=5, max=10)\n\n # Create noisy signal\n test_data[, paste0(\"feature_\", feature) := rnorm(\n n=n_rows, mean = mu, sd = sdev)*target + target]\n }\n\n # Split data into test/train\n test_data[, index_fraction := .I/.N]\n split_data <- list(\n \"train\" = test_data[index_fraction < (train_fraction)],\n \"test\" = test_data[index_fraction >= (train_fraction)]\n )\n\n # Make vector of feature names\n feature_names <- paste0(\"feature_\", 1:feature_count)\n\n # Make test/train matrix and labels\n split_data[[\"test_trix\"]] <- as.matrix(split_data$test[, feature_names, with=FALSE])\n split_data[[\"train_trix\"]] <- as.matrix(split_data$train[, feature_names, with=FALSE])\n split_data[[\"test_labels\"]] <- as.logical(split_data$test$target + 1) \n split_data[[\"train_labels\"]] <- as.logical(split_data$train$target + 1)\n\n return(split_data)\n}\n\n# Build the tree\nbuild_model <- function(split_data, objective){\n\n # Make evaluation matrix\n train_dtrix <-\n xgb.DMatrix(\n data = split_data$train_trix, label = split_data$train_labels)\n\n # Train the model\n model <- xgb.train(\n data = train_dtrix,\n watchlist = list(\n train = train_dtrix),\n nrounds = 5,\n objective = objective,\n eval_metric = \"rmse\"\n )\n\n return(model)\n}\n\nsplit_data <- generate_test_data()\ncat(\"\\nUsing built-in binary:logistic objective.\\n\")\ntest_1 <- build_model(split_data, \"binary:logistic\")\ncat(\"\\n\\nUsing custom objective\")\ntest_2 <- build_model(split_data, logloss)\n"} {"post_id":38793194,"creation_date":"2016-08-05 15:47:13","snippet":"library(ggplot2)\nlibrary(gridExtra)\n\na <- ggplotGrob( ggplot(iris[iris$Species != \"setosa\",], aes(x=Sepal.Length, y=Petal.Width*100000, color=Species)) + geom_line() + theme(legend.position=\"none\"))\n\nb <- ggplotGrob( ggplot(iris[iris$Species != \"setosa\",], aes(x=Sepal.Length, y=Petal.Length, color=Species)) + geom_line() + theme(legend.position=\"none\"))\n\nc <- ggplotGrob(ggplot(head(mpg, 100), aes(class)) + geom_bar() + facet_grid(.~manufacturer, scales=\"free_x\"))\n\ng1 <- rbind(a, b, size=\"first\")\ngrid.arrange(g1, c, ncol=1)\n"} {"post_id":38816935,"creation_date":"2016-08-07 17:51:47","snippet":"require(RCurl)\nrequire(httr)\nfull_url <- oauth_callback()\nfull_url <- gsub(\"(.*localhost:[0-9]{1,5}/).*\", x=full_url, replacement=\"\\1\")\nprint(full_url)\n\n\napp_name <- \"teamusainrio\"\nclient_id <- \"a36424058cdf424c8e8b2d5cc2af1b15\"\nclient_secret <- \"398863caad6a4171ad10eb201870065b\"\nscope = \"basic\"\n\ninstagram <- oauth_endpoint(\n authorize = \"https://api.instagram.com/oauth/authorize\",\n access = \"https://api.instagram.com/oauth/access_token\")\nmyapp <- oauth_app(app_name, client_id, client_secret)\n\nig_oauth <- oauth2.0_token(instagram, myapp,scope=\"basic\", type = \"application/x-www-form-urlencoded\",cache=FALSE)\n"} {"post_id":38816935,"creation_date":"2016-08-07 17:51:47","snippet":"tmp <- strsplit(toString(names(ig_oauth$credentials)), '\"')\ntoken <- tmp[[1]][4]\nusername <- \"therock\"\nuser_info <- fromJSON(getURL(paste('https://api.instagram.com/v1/users/search?q=',username,'&access_token=',token,sep=\"\")),unexpected.escape = \"keep\")\nreceived_profile <- user_info$data[[1]]\n"} {"post_id":38817153,"creation_date":"2016-08-07 18:18:53","snippet":"#set directory\nsetwd('[YOUR DIRECTORY]')\n\n# setup libraries\nlibrary(dplyr)\nlibrary(XML)\nlibrary(ZillowR)\nlibrary(RCurl)\n\n# setup api key\nset_zillow_web_service_id('[YOUR API KEY]')\n\nxml = GetSearchResults(address = '120 East 7th Street', citystatezip = '10009')\ndata = xmlParse(xml)\n"} {"post_id":19809168,"creation_date":"2013-11-06 10:07:50","snippet":"units<-which(names(dt)==\"kA\") # Gives me a vector with the positions needed.\ndt[,units:=units*1000] #Multiplies the vector by 1000\nnames(dt) <- gsub(\"kA\", \"A\", names(dt)) # Changes \"kA\" to \"A\"\n\nunits<-which(names(dt)==\"kV\") # Gives me a vector with the positions needed.\ndt[,units:=units*1000] #Multiplies the vector by 1000\nnames(dt) <- gsub(\"kV\", \"V\", names(dt)) # Changes \"kV\" to \"V\"\n\nunits<-which(names(dt)==\"kW\") # Gives me a vector with the positions needed.\ndt[,units:=units*1000] #Multiplies the vector by 1000\nnames(dt) <- gsub(\"kW\", \"W\", names(dt)) # Changes \"kW\" to \"W\"\n"} {"post_id":58332602,"creation_date":"2019-10-11 00:10:24","snippet":"library(eulerr)\nset.seed(3)\ngroup1_size <- 13622\ngroup2_size <- 40219 \ngroup3_size <- 17120\n\ngroup2_group1_group3 = as.integer(group1_size*0.2)\ngroup1_group3_size <- as.integer(group1_size*0.6) - group2_group1_group3 \ngroup1_group2_size <- as.integer(group1_size*0.3) - group2_group1_group3 \ngroup3_size_group2_size <- as.integer(group3_size*0.35) - group2_group1_group3 \ngroup1_only_direct <- group1_size - group1_group3_size - group1_group2_size - group2_group1_group3 \ngroup2_only <- group2_size - group1_group2_size - group3_size_group2_size - group2_group1_group3 \ngroup3_only_direct <- group3_size - group3_size_group2_size - group1_group3_size - group2_group1_group3 \n\n\nfit <- euler(c(Group1 = group1_only_direct,\n Group2 = group3_only_direct,\n Group3 = group2_only,\n \"Group1&Group3\" = group1_group3_size,\n \"Group1&Group2\" = group1_group2_size,\n \"Group3&Group2\" = group3_size_group2_size,\n \"Group2&Group1&Group3\" = group2_group1_group3 \n )\n )\nplot(fit,\n quantities = list(fontsize = 12),\n main = \"Example Diagram\")\n"} {"post_id":19809824,"creation_date":"2013-11-06 10:38:17","snippet":"#initialize\nlibrary(ggplot2) \n\nTestData <- data.frame( a = rep(LETTERS[1:4],10),\n b = rep(c('A','B'),20),\n c = rep(LETTERS[1:5],each=8),\n d = rep(c('A','B'),2,each=10),\n m1 = rnorm(40),\n m2 = rnorm(40),\n m3 = rnorm(40),\n m4 = rnorm(40),\n m5 = rnorm(40),\n x = rep(1:5,each=8)\n)\n\n#helper function (convert vector to named list)\nnamel<-function (vec){\n tmp<-as.list(vec)\n names(tmp)<-as.character(unlist(vec))\n tmp\n}\n\n# Function to aggregate data based on selected columns (Source Columns)\nAggregateData <- function(data,Columns=NA) {\n\n require(sqldf)\n if (all(is.na(Columns))) {\n sql <- \"select \n sum(m1) as m1, sum(m2) as m2, sum(m3) as m3, sum(m4) as m4, sum(m5) as m5, x\n from TestData group by x\" \n sqldf(sql) \n } else {\n sql <- paste(\"select \", paste(Columns, collapse =','), \",\n sum(m1) as m1, sum(m2) as m2, sum(m3) as m3, sum(m4) as m4, sum(m5) as m5, x\n from TestData group by \",paste(Columns, collapse =','),\", x\")\n sqldf(sql) \n }\n}\n\n# Function to plot data\nPlotData <- function(data,x=\"x\",y=\"m1\") { \n ggplot(data, aes_string(x=x, y=y)) + geom_line()\n}\n"} {"post_id":38822863,"creation_date":"2016-08-08 06:51:03","snippet":"library(shiny)\nlibrary(shinyjs)\nlibrary(reshape2)\nlibrary(ggplot2)\n\ndat <- data.frame(matrix(rnorm(60, 2, 3), ncol=3))\ndat <- melt(dat)\n\nrunApp(shinyApp(\n ui = fluidPage(\n selectizeInput(\"select\",\"Select:\", choices=as.list(levels(dat$variable)), selected=\"X1\",multiple =TRUE),\n uiOutput('myPanel'),\n plotOutput(\"plot\"),\n downloadButton('downloadplot',label='Download Plot')\n ),\n server = function(input, output, session) {\n cols <- reactive({\n lapply(seq_along(unique(input$select)), function(i) {\n colourInput(paste(\"col\", i, sep=\"_\"), \"Choose colour:\", \"black\") \n })\n })\n\n output$myPanel <- renderUI({cols()})\n\n cols2 <- reactive({ \n if (is.null(input$col_1)) {\n cols <- rep(\"#000000\", length(input$select))\n } else {\n cols <- unlist(colors())\n }\n cols})\n\n testplot <- function(){\n dat <- dat[dat$variable %in% input$select, ]\n ggplot(dat, aes(x=variable,y=value, fill=cols2()[1])) + geom_boxplot()}\n\n output$plot <- renderPlot({testplot()})\n\n output$downloadplot <- downloadHandler(\n filename =\"plot.pdf\",\n content = function(file) {\n pdf(file, width=12, height=6.3)\n print(testplot())\n dev.off()\n })\n }\n))\n"} {"post_id":76513412,"creation_date":"2023-06-20 09:46:05","snippet":"library(gplots)\nlibrary(ComplexHeatmap)\nmat=read.table(\"Matrix.txt\", header=T, sep=\"\\t\", row.names = 1)\nmat.z<-t(apply(mat,1,scale))\nHeatmap((mat.z), row_names_gp = gpar(fontsize = 2),cluster_rows = T, col = bluered(256),cluster_columns = T,column_labels = colnames(mat), name=\"Signatures\")\n"} {"post_id":38822718,"creation_date":"2016-08-08 06:41:43","snippet":"set.seed(1)\nx <- runif(2000, 0, 100)\ny <- runif(2000, 0, 100)\nplot(y~x)\npoints( x = 21, y = 70, col = 'red', cex = 2, bg = 'red')\n"} {"post_id":57701238,"creation_date":"2019-08-28 23:37:51","snippet":"group1=rep(1:5,each=2)\ngroup2=rep(6:10, each=2)\ndata1=c(1,1,1,1,1,4,5,6,3,8)\ndata2=c(5,4,5,7,8,5,2,1,1,5)\ndata3=c(6,6,8,9,5,4,3,3,1,1)\nDF=data.frame(group1,group2,data1,data2,data3)\n"} {"post_id":57703920,"creation_date":"2019-08-29 06:06:05","snippet":"# simulate linear model\na <- 3 # intercept\nb <- 2 # slope\n\n# data\nx <- rnorm(28, 0, 1)\neps <- rnorm(28, 0, 2)\ny <- a + b*x + eps\n\n# put data into list\ndata_reg <- list(N = 28, x = x, y = y)\n\n# create the model string\n\nms <- \"\n data {\n int N;\n vector[N] x;\n vector[N] y;\n }\n parameters {\n real alpha;\n real beta;\n real sigma;\n }\n model {\n vector[N] mu;\n sigma ~ cauchy(0, 2);\n beta ~ normal(0,10);\n alpha ~ normal(0,100);\n for ( i in 1:N ) {\n mu[i] = alpha + beta * x[i];\n }\n y ~ normal(mu, sigma);\n }\n\"\n\n# now fit the model in stan\nfit1 <- stan(model_code = ms, # model string\n data = data_reg, # named list of data\n chains = 1, # number of Markov chains\n warmup = 1e3, # number of warmup iterations per chain\n iter = 2e3) # show progress every 'refresh' iterations\n\n# extract the sample estimates\npost <- extract(fit1, pars = c(\"alpha\", \"beta\", \"sigma\"))\n\n# now for the density plots. Write a plotting function\ndensFunct <- function (parName) {\n g <- ggplot(postDF, aes_string(x = parName)) + \n geom_histogram(aes(y=..density..), fill = \"white\", colour = \"black\", bins = 50) +\n geom_density(fill = \"skyblue\", alpha = 0.3)\n return(g)\n}\n\n# plot \ngridExtra::grid.arrange(grobs = lapply(names(postDF), function (i) densFunct(i)), ncol = 1)\n"} {"post_id":57706451,"creation_date":"2019-08-29 08:50:05","snippet":"##' A function for a factorial decomposition of a number\n##' @title decomp\n##' @param n integer\n##' @return a String with the factorial decomposition\n##' @author krisselack\n\ndecomp <- function(n) {\n\n # https://stackoverflow.com/questions/19767408/prime-number-function-in-r\n is.prime <- function(n) n == 2L || all(n %% 2L:ceiling(sqrt(n)) != 0)\n\n p <- 2:n\n primes <- p[as.logical(vapply(p, is.prime, 1))]\n erg <- NULL\n\n pointwise <- function(x) {\n\n primloop <- primes[primes<=x]\n\n for(j in primloop){\n\n while(x %% j == 0){\n x <- x/j\n erg <- c(erg, j)\n }\n }\n\n if(length(erg)>0)\n return(erg)\n }\n\n erg2 <- unlist(lapply(p, pointwise))\n\n ergfin <- table(erg2)\n\n namen <- paste(ifelse(ergfin>1, paste0(names(ergfin), \"^\", ergfin),\n paste(names(ergfin))),\n collapse = \" * \")\n\n return(namen)\n}\n\ndecomp(5) # -> \"2^3 * 3 * 5\"\ndecomp(12) # -> \"2^10 * 3^5 * 5^2 * 7 * 11\"\ndecomp(17) # -> \"2^15 * 3^6 * 5^3 * 7^2 * 11 * 13 * 17\"\ndecomp(25) # -> \"2^22 * 3^10 * 5^6 * 7^3 * 11^2 * 13 * 17 * 19 * 23\"\n"} {"post_id":57717929,"creation_date":"2019-08-29 21:28:53","snippet":" names <- c(\"Richard\", \"Mortimer\", \"Elizabeth\", \"Jeremiah\")\n posts <- c(\"I'm trying to find a solution for a problem with my neighbour, she keeps mowing the lawn on sundays when I'm trying to sleep in from my night shift\", \"Personally, I like to deal with annoying neighbours by just straight up confronting them. Don't shy away. There are always ways to work things out.\", \"Personally, I like to deal with annoying neighbours by just straight up confronting them. Don't shy away. There are always ways to work things out. That sounds quite aggressive. How about just talking to them in a friendly way, first?\", \"That sounds quite aggressive. How about just talking to them in a friendly way, first? Didn't mean to sound aggressive, rather meant just being straightforward, if that makes any sense\")\n\n duplicateposts <- data.frame(names, posts)\n\n posts2 <- c(\"I'm trying to find a solution for a problem with my neighbour, she keeps mowing the lawn on sundays when I'm trying to sleep in from my night shift\", \"Personally, I like to deal with annoying neighbours by just straight up confronting them. Don't shy away. There are always ways to work things out.\", \"That sounds quite aggressive. How about just talking to them in a friendly way, first?\", \"Didn't mean to sound aggressive, rather meant just being straightforward, if that makes any sense\")\n\n postsnoduplicates <- data.frame(names, posts2)\n"} {"post_id":76519999,"creation_date":"2023-06-21 04:42:38","snippet":"data(iris)\niris$ID <- paste(\"sample\", rownames(iris))\nselected_marker <- \"Sepal.Length\"\ngroup_for_color <- \"Species\"\nX <- iris[,selected_marker]\nplot_data <- data.frame(X, Group=iris[, group_for_color],\n ID=iris$ID, stringsAsFactors=FALSE)\nnames(plot_data)[1] <- selected_marker\nplot_data$Group <- factor(plot_data$Group, levels=gtools::mixedsort(unique(plot_data$Group)))\nplot_palette <- c(\"#E41A1C\", \"#377EB8\", \"#4DAF4A\")\nlegend_cols <- 1\nstroke <- 1\nsize <- 20\nbottom <- 0\ntop <- 100\nbreaks <- seq(0, 100, 10)\nP <- ggplot2::ggplot(plot_data, ggplot2::aes(x=!!ggplot2::sym(selected_marker), color=Group, fill=Group)) +\n ggplot2::geom_density(alpha=0.25, linewidth=stroke) +\n ggplot2::ggtitle(selected_marker) +\n ggplot2::scale_fill_manual(group_for_color, values=plot_palette, drop=FALSE, guide=\"none\") +\n ggplot2::scale_color_manual(group_for_color, values=plot_palette, drop=FALSE,\n guide=ggplot2::guide_legend(ncol=legend_cols,\n override.aes=list(shape=19, size=size))) +\n ggplot2::scale_y_continuous(\"percent\", labels=scales::percent, limits=c(bottom, top), breaks=breaks) +\n ggplot2::theme_light() +\n ggplot2::theme(plot.title = ggplot2::element_text(face=\"bold\",size=size),\n axis.text=ggplot2::element_text(size=size),\n axis.title=ggplot2::element_text(size=size,face=\"bold\"),\n legend.text=ggplot2::element_text(size=size),\n legend.title=ggplot2::element_text(size=size,face=\"bold\"),\n legend.position=\"bottom\",\n legend.key.size=grid::unit(0.5,\"inch\"),\n plot.margin = grid::unit(c(1,1,1,1), \"lines\"))\ngrDevices::pdf(file=\"test.pdf\", height=10, width=10)\nprint(P)\ngrDevices::dev.off()\n"} {"post_id":57731066,"creation_date":"2019-08-30 17:37:15","snippet":"data(\"mtcars\")\n list.avg <- list(\"mpg\",\"wt\",\"hp\")\n list.max <- list(\"mpg\",\"hp\",\"wt\",\"qsec\")\n list.min <- list(\"mpg\",\"hp\",\"wt\",\"qsec\")\n list.group <- list(\"cyl\",\"vs\",\"am\",\"gear\",\"carb\")\n"} {"post_id":57729914,"creation_date":"2019-08-30 15:55:38","snippet":"# Color palette for the heatmap\ncolors = c(seq(-5,-1,length=1000),seq(-.999999,.999999,length=1000),seq(1, 5,length=1000))\nmy_palette <- colorRampPalette(c(\"blue\", \"white\", \"red\"))(n = 2999)\n\ndata.random <- data.frame(matrix(data=rnorm(150), ncol=15, nrow=10))\nrownames(data.random) <- letters[1:10]\ncolnames(data.random) <- LETTERS[1:15]\nh <- pheatmap(data.random,\n cluster_rows=FALSE,\n cluster_cols=FALSE,\n legend=TRUE,\n color=my_palette,\n breaks=colors,\n show_rownames=TRUE,\n show_colnames=TRUE\n)\n"} {"post_id":57734832,"creation_date":"2019-08-31 02:52:02","snippet":"library(tidyverse)\ncon <- DBI::dbConnect(RSQLite::SQLite(), \":memory:\")\ndf_1 <- tibble(A = c(\"a\", \"aa\"), B = c(\"b\", \"bb\"), D = c(\"d\", NA))\ndf_2 <- tibble(A = c(\"a\", \"aa\"), C = c(\"c\", \"cc\"), D = c(\"d\", NA))\ncopy_to(con, df_1, overwrite = T)\ncopy_to(con, df_2, overwrite = T)\ndt_1 <- tbl(con, \"df_1\")\ndt_2 <- tbl(con, \"df_2\")\n\ndf_1\n#> # A tibble: 2 x 3\n#> A B D \n#> \n#> 1 a b d \n#> 2 aa bb \n\ndf_2\n#> # A tibble: 2 x 3\n#> A C D \n#> \n#> 1 a c d \n#> 2 aa cc \n\ndt_1\n#> # Source: table [?? x 3]\n#> # Database: sqlite 3.29.0 [:memory:]\n#> A B D \n#> \n#> 1 a b d \n#> 2 aa bb \n\ndt_2\n#> # Source: table [?? x 3]\n#> # Database: sqlite 3.29.0 [:memory:]\n#> A C D \n#> \n#> 1 a c d \n#> 2 aa cc \n"} {"post_id":57715415,"creation_date":"2019-08-29 17:44:45","snippet":"df = data.frame(A = c('Dog', '5', '7.04'), B = c('Cat', '12', '1.23'))\nwb = createWorkbook()\naddWorksheet(wb, \"Sheet2\")\nwriteDataTable(wb, \"Sheet2\", df)\noutput_file = \"C:\\\\Users\\\\johndoe\\\\documents\\\\excel_file.xlsx\"\nsaveWorkbook(wb, output_file)\n"} {"post_id":57718419,"creation_date":"2019-08-29 22:28:47","snippet":" set.seed(1)\n rstr <- function(n,k){ # vector of n random char(k) strings\n sapply(1:n,function(i) {do.call(paste0,as.list(sample(letters,k,replace=T)))})\n }\n\nstr<- c(paste0(\"aa\",rstr(10,3)),paste0(\"bb\",rstr(10,3)),paste0(\"cc\",rstr(10,3)))\n# Levenshtein Distance\n d <- adist(str)\n rownames(d) <- str\nhc <- hclust(as.dist(d))\n"} {"post_id":57734180,"creation_date":"2019-08-30 23:46:56","snippet":"usa <- ggplot() +\n borders(\"usa\", colour = \"gray85\", fill = \"gray80\") +\n theme_map() \n\nmap <- usa +\n geom_point(aes(x = longitude, y = latitude, cumulative=TRUE,\n frame=month,stat = 'identity' ),data = DF )\nmap\n\n# Generate the Visual and a HTML output\nggp <- ggplotly(map)%>%\n animation_opts(transition = 0)\nggp\n"} {"post_id":57737697,"creation_date":"2019-08-31 11:39:15","snippet":"library(shiny)\nlibrary(data.table)\nmtcars_dt <- data.table(mtcars)\n\nui <- basicPage(\n selectInput(\"var\", \"Select variable\", names(mtcars)),\n textOutput(\"out1\"),\n textOutput(\"out2\")\n)\n\n\nserver <- function(input, output) {\n\noutput$out1 <- renderText({\n mtcars[1:3 ,input$var]\n })\n\noutput$out2 <- renderText({\n mtcars_dt[1:3 , ..input$var]\n})\n\n}\n\nshinyApp(ui, server)\n"} {"post_id":57754335,"creation_date":"2019-09-02 09:15:53","snippet":"\nurl <- \"https://www.zlacnene.sk/akciovy-tovar/strana-2\"\n\nnew <- list()\n\ncast <- read_html(url) %>% html_nodes(\"h2 a\") %>% html_text()\n\ns <- html_session(\"https://www.zlacnene.sk/akciovy-tovar/strana-2\")\n\nfor (i in cast[1:20]) {\n\n page <- s %>% follow_link(i) %>% read_html()\n\n new[[i]] <- page %>% html_nodes(\".breadcrumbs a:nth-child(3)\")\n\n}\n\n\n"} {"post_id":57750926,"creation_date":"2019-09-02 02:48:01","snippet":"library(tidyverse)\nlibrary(ggalluvial)\nlibrary(alluvial)\n\nA_col <- \"firebrick3\"\nB_col <- \"darkorange\"\nC_col <- \"aquamarine2\"\nD_col <- \"dodgerblue2\"\nE_col <- \"darkviolet\"\nF_col <- \"chartreuse2\"\nG_col <- \"goldenrod1\"\nH_col <- \"gray73\"\nset.seed(39)\n\nggplot(df,\n aes(y = Time, axis1 = Activity, axis2 = Category, axis3 = Positions)) +\n geom_alluvium(aes(fill = Positions, color = Positions), \n width = 4/12, alpha = 0.5, knot.pos = 0.3) +\n geom_stratum(width = 4/12, color = \"grey36\") +\n geom_text(stat = \"stratum\", label.strata = TRUE) +\n scale_x_continuous(breaks = 1:3, \n labels = c(\"Activity\", \"Category\", \"Positions/Movements\"), expand = c(.01, .05)) +\n ylab(\"Time 24 hours\") +\n scale_fill_manual(values = c(A_col, B_col, C_col, D_col, E_col, F_col, G_col, H_col)) +\n scale_color_manual(values = c(A_col, B_col, C_col, D_col, E_col, F_col, G_col, H_col)) +\n ggtitle(\"Physical Activity during the week and weekend\") +\n theme_minimal() +\n theme(legend.position = \"none\", panel.grid.major = element_blank(), \n panel.grid.minor = element_blank(), axis.text.y = element_blank(), \n axis.text.x = element_text(size = 12, face = \"bold\"))\n\n# I also have this code that I run without pre-choosing the colours.\n# I like this one because the flow diagram doesn't have any border.\n\nggplot(df,\n aes(y = Time, axis1 = Activity, axis2 = Category, axis3 = Positions)) +\n scale_x_discrete(limits = c(\"Activity\", \"Category\", \"Positions/Moviments\"), \n expand = c(.01, .05)) +\n ylab(\"Time 24 hours\") +\n geom_alluvium(aes(fill = Positions), width = 4/12, alpha = 0.5, knot.pos = 0.3) +\n geom_stratum() + geom_text(stat = \"stratum\", label.strata = TRUE) +\n theme_minimal() +\n ggtitle(\"Physical Activity during the week and weekend\") +\n theme(legend.position = \"none\", panel.grid.major = element_blank(), \n panel.grid.minor = element_blank(), axis.text.y = element_blank(), \n axis.text.x = element_text(size = 12, face = \"bold\"))\n"} {"post_id":57760809,"creation_date":"2019-09-02 17:26:56","snippet":"################# Loadin Require Libraries #################\nlib <- .libPaths()[1]\nrequired.packages <- c('caret','readxl')\ni1 <- !(required.packages %in% row.names(installed.packages()))\nif(any(i1)) {\n install.packages(required.packages[i1], dependencies = TRUE, lib = lib) \n}\nlapply(required.packages, require, character.only = TRUE)\n"} {"post_id":57761043,"creation_date":"2019-09-02 17:52:49","snippet":"month = sample(1:12, 5000, replace= TRUE)\nyear = sample(2000:2019,5000, replace = TRUE)\nloss = round(rlnorm(5000,7,2))\nclaim.data = cbind(month, year, loss)\nhead(claim.data)\n\nmax.year = aggregate(loss~year, data = claim, FUN = max)\n"} {"post_id":76553441,"creation_date":"2023-06-26 04:00:52","snippet":"library(tidymodels)\nlibrary(dplyr)\nlibrary(stringr)\nlibrary(textrecipes)\nlibrary(hardhat)\n\nurl <- \"https://gutenberg.org/cache/epub/2701/pg2701-images.html\"\nwords <- readLines(url, encoding = \"UTF-8\") %>% str_extract_all('\\\\w+\\\\b') %>% unlist()\nx <- rnorm(n = 6000000, mean = 18, sd = 14)\nx <- x[x > 0]\n\ncorpus <- \n lapply(x, function(i) {\n c('text' = paste(sample(words, size = i, replace = TRUE), collapse = ' '))\n }) %>% \n bind_rows() %>% \n mutate(ID = 1:n(), Class = factor(sample(c(0, 1), n(), replace = TRUE)))\n"} {"post_id":76553441,"creation_date":"2023-06-26 04:00:52","snippet":"# prep\ncorpus_split <- initial_split(corpus, strata = Class) # split\ncorpus_train <- training(corpus_split)\ncorpus_test <- testing(corpus_split)\nfolds <- vfold_cv(corpus_train) #k-fold cv prep\nsparse_bp <- hardhat::default_recipe_blueprint(composition = \"dgCMatrix\") # use sparse matrices\nsmaller_lambda <- grid_regular(penalty(range = c(-5, 0)), levels = 20) # hyperparameter calibration\n\n# recipe\nrecipe <-\n recipe(Ad ~ text, data = corpus_train) %>% \n step_tokenize(text) %>%\n step_stopwords(text, custom_stopword_source = 'twclid') %>% \n step_tokenfilter(text, max_tokens = 10000) %>% \n step_tfidf(text)\n\n# lasso model\nlasso_spec <- logistic_reg(penalty = tune(), mixture = 1) %>% # tuning the penalty hyperparameter\n set_mode(\"classification\") %>%\n set_engine(\"glmnet\")\n\n# workflow\nsparse_wf <- workflow() %>%\n add_recipe(recipe, blueprint = sparse_bp) %>%\n add_model(lasso_spec)\n\n# fit\nsparse_rs <- tune_grid(\n sparse_wf,\n folds,\n grid = smaller_lambda\n)\n"} {"post_id":76556850,"creation_date":"2023-06-26 12:49:23","snippet":"Names <- c(\"ExampleA\",\"ExampleB\",\"ExampleC\",\"ExampleD\", \"ExampleE\", \"ExampleF\",\"ExampleG\", \"ExampleH\")\nCounts <- c(4,3,2,1,-1,-2,-3,-4)\nType <- c(\"X\",\"X\",\"X\",\"X\", \"Y\",\"Y\",\"Y\",\"Y\")\ndf <-data.frame(Names,Counts, Type)\n\nggplot(df, aes(x=reorder(Names,Counts), y=Counts, fill=Type))+\n geom_col()+\n coord_flip()+\n theme_minimal()\n\n"} {"post_id":57778952,"creation_date":"2019-09-03 21:28:32","snippet":"library(inline)\nlibrary(Rcpp)\ninc <- \n\"#include \n\ntemplate \nclass SillyWrapper \n{\npublic:\n Eigen::Matrix m_vec;\n SillyWrapper(const Eigen::Matrix& vec) : m_vec(vec);\n};\"\nsrc <- \n'SillyWrapper mything(Rcpp::as>>(x));'\n\nlibrary(inline)\nfun <- cxxfunction(signature(x=\"numeric\"),\n body=src, \n includes=inc, \n plugin=\"Rcpp\")\nfun(rnorm(3))\n"} {"post_id":57778952,"creation_date":"2019-09-03 21:28:32","snippet":"library(inline)\nlibrary(Rcpp)\ninc <- \n'template \nclass SillyWrapper \n{\npublic:\n Eigen::Matrix m_vec;\n SillyWrapper(const Eigen::Matrix& vec) : m_vec(vec);\n};'\nsrc <- \n 'SillyWrapper mything(Rcpp::as>>(x));'\nplug <- Rcpp.plugin.maker(include.before = \"#include \", \n LinkingTo = \"-I/usr/include/eigen3/\") # correct arg name?\ninline::registerPlugin(\"eigenDemo\", plug)\nfun <- cxxfunction(signature(x=\"numeric\"),\n body=src, \n includes=inc, \n plugin=\"eigenDemo\")\n"} {"post_id":76568667,"creation_date":"2023-06-27 21:14:07","snippet":"library(quantmod)\n\nticker<-\"AAPL\"\nstart_date <- as.Date(\"2020-01-01\")\nend_date <- as.Date(\"2021-01-01\")\ngetSymbols(\"AAPL\", from=start_date, to=end_date)\n\ndata<-AAPL$AAPL.Adjusted\n"} {"post_id":76574229,"creation_date":"2023-06-28 14:32:28","snippet":"library(dplyr)\nlibrary(purrr)\ndf <- tibble(x = c(1,2),\n y = c(3, 4))\n\nfns <- list(minus_y = function(x,y) x - y,\n plus_y = function(x,y) x + y)\n\n# What I used to do, but is now deprecated\ndf %>%\n mutate(across(x, fns, y))\n\n## A tibble: 2 x 4\n# x y x_minus_y x_plus_y\n# \n#1 1 3 -2 4\n#2 2 4 -2 6\n"} {"post_id":76579854,"creation_date":"2023-06-29 09:38:40","snippet":"library(dplyr)\nlibrary(sf)\nlibrary(ggplot2)\nlibrary(nngeo)\n\nnc <- st_read(system.file(\"shape/nc.shp\", package=\"sf\"))\nset.seed(2806)\nnc_sample=dplyr::sample_n(nc,10)\nggplot() + geom_sf(data = nc_sample)\n\nco=st_connect(nc_sample[1,], nc_sample %>% slice(st_distance(nc_sample[1,],nc_sample) %>%\n units::drop_units() %>% \n as.data.frame() %>%\n mutate_if(is.numeric, ~na_if(., 0)) %>%\n rowwise() %>% which.min()))\nall_connexion=st_sf(co)\n\nfor(i in 2:length(nc_sample$AREA)){\n co=st_connect(nc_sample[i,], nc_sample %>% slice(st_distance(nc_sample[i,],nc_sample) %>%\n units::drop_units() %>% \n as.data.frame() %>%\n mutate_if(is.numeric, ~na_if(., 0)) %>%\n rowwise() %>% which.min()))\n all_connexion = rbind(all_connexion,co)\n}\n\nggplot() + \n geom_sf(data = all_connexion) +\n geom_sf(data = nc_sample) \n"} {"post_id":57795478,"creation_date":"2019-09-04 20:50:52","snippet":"library(sf)\nlibrary(ggplot)\nlibrary(dplyr)\n\nnc <- st_read(system.file(\"shape/nc.shp\", package=\"sf\")) %>%\n mutate(type= case_when(\n BIR74>16000 ~\"High\",\n TRUE ~\"Low\"\n ) %>% factor(levels = c(\"Low\", \"High\"))) #the levels are ordered to avoid the grey lines overwriting the red ones\n\nnc %>%\n ggplot(.) + \n geom_sf(aes(fill = BIR74, colour = type)) + #does the job but the coloured borders are quite thing\n scale_color_manual(values = c( \"#666666\",\"#F8766D\"))\n\n\nnc %>%\n ggplot(.) + \n geom_sf(aes(fill = BIR74, colour = type, \n lwd = ifelse(type ==\"High\", 1, 0.5)) #The values can be anything and it still looks rubbish\n ) + \n scale_color_manual(values = c( \"#666666\",\"#F8766D\"))\n"} {"post_id":57802225,"creation_date":"2019-09-05 09:17:42","snippet":"library(tidyverse)\nlibrary(shiny)\nlibrary(rmarkdown)\nlibrary(knitr)\n\nui <- fluidPage(\n sidebarLayout(\n sidebarPanel(fileInput(\"file\",\"Upload your file\"), \n width =2),\n mainPanel(\n width = 10,\n downloadButton(\"report\", \"Download report\"),\n tableOutput(\"table\"),\n tags$br(),\n tags$hr(),\n plotOutput(\"plot1\"), \n tags$br(),\n tags$hr(),\n plotOutput(\"plot2\")\n )\n )\n)\n\nserver <- function(input,output){\n\n data <- reactive({\n file1 <- input$file\n if(is.null(file1)){return()} \n read.csv(file1$datapath, header=TRUE, sep=',')\n })\n\n\n output$table <- renderTable({\n if (is.null(data())) { return() }\n\n df <- data() %>% \n dplyr::select(cut, color, price) %>% \n dplyr::group_by(cut, color) %>% \n dplyr::summarise_all(funs(min(.), mean(.), median(.),max(.),sd(.), n() )) \n }) \n\n table_rmd <- reactive({\n df <- data() %>% \n dplyr::select(cut, color, price) %>% \n dplyr::group_by(cut, color) %>% \n dplyr::summarise_all(funs(min(.), mean(.), median(.),max(.),sd(.), n() )) \n })\n\n output$plot1 <- renderPlot({\n if (is.null(data())) { return() }\n\n ggplot(data(), aes (x =carat, y = price, col = color))+\n geom_point()+\n facet_wrap(~cut)\n }\n )\n\n plot_rmd <- reactive({\n chart <- ggplot(data(), aes (x =carat, y = price, col = color))+\n geom_point()+\n facet_wrap(~cut)\n chart\n }\n )\n\n #https://shiny.rstudio.com/articles/generating-reports.html\n output$report <- downloadHandler(\n filename = \"report.pdf\",\n content = function(file) {\n tempReport <- file.path(tempdir(), \"report.Rmd\")\n file.copy(\"report.Rmd\", tempReport, overwrite = TRUE)\n\n params <- list(table1 = table_rmd(),\n plot1 = plot_rmd())\n\n rmarkdown::render(tempReport, output_file = file,\n params = params,\n envir = new.env(parent = globalenv())\n )\n }\n )\n} \n\n\nshinyApp(ui=ui, server = server)\n"} {"post_id":76589595,"creation_date":"2023-06-30 13:59:52","snippet":"rm(list=ls())\nlibrary(giscoR)\nlibrary(rworldmap)\nlibrary(tidyverse)\nlibrary(sf)\n\ncrsLONGLAT <- \"+proj=longlat +datum=WGS84 +no_defs\"\ncrsrobin <- \"+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs\"\n\n# Using giscoR\nworld_sf <- gisco_get_countries(resolution = 10)\n\nggplot() +\n geom_sf(data = world_sf)\n\nworld_robinson <- st_transform(world_sf, \n crs = crsrobin) ## looks great\nggplot() +\n geom_sf(data = world_robinson) ## looks great\n\n## Pacific centered Robinson\ncrsrobin <- \"+proj=robin +lon_0=-180 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs\"\nworld_robinson <- st_transform(world_sf, \n crs = crsrobin) ## horizontal artifacts\n\nggplot() +\n geom_sf(data = world_robinson) ## horizontal artifacts\n"} {"post_id":76589595,"creation_date":"2023-06-30 13:59:52","snippet":"world_box <- st_cast(st_combine(st_as_sf(data.frame(\"x\"=c(-180, -180, 180, 180),\"y\"=c(90, -90, -90, 90)),coords = c(\"x\",\"y\"), crs=crsLONGLAT)),\"POLYGON\")\nworld_box_robin <- st_transform(world_box, crs=crsrobin)\n\nggplot() + geom_sf(data=world_box) + geom_sf(data=world_sf)\n\nb <- st_bbox(world_box)\nggplot() + geom_sf(data=world_sf) +\n coord_sf(crs = crsLONGLAT, xlim = c(b[\"xmin\"], b[\"xmax\"]), ylim = c(b[\"ymin\"], b[\"ymax\"]))\n\n\nggplot()+ geom_sf(data=world_box_robin) + geom_sf(data=world_robinson) \n\n\nb <- st_bbox(world_box_robin)\nggplot() + geom_sf(data=world_robinson) + \n coord_sf(crs = crsrobin, xlim = c(b[\"xmin\"], b[\"xmax\"]), ylim = c(b[\"ymin\"], b[\"ymax\"]))\n\n"} {"post_id":57796528,"creation_date":"2019-09-04 23:02:02","snippet":"set.seed(1)\nX <- matrix(runif(400*150000), nrow = 150000)\ny1 <- runif(150000)\ny2 <- runif(150000)\n\nmod1 <- lm(y1 ~ X)\nmod2 <- lm(y2 ~ X)\n"} {"post_id":76589390,"creation_date":"2023-06-30 13:31:00","snippet":"library(ggplot2)\n\n#' tests if a rectangle overlaps with any other rectangle from a set of rectangles\n#'\n#' @param testRect the rectangle to be tested for overlaps (in the form of any structure having the $xmin, $xmax, $ymin, and $ymax attributes)\n#' @param rectList a data frame with the xmin, xmax, ymin, and ymax columns containing the set of rectangles to test the overlaps with\n#' @returns a Boolean value, TRUE if there any any overlaps, FALSE if there are not\n#' \noverlaps_any <- function(testRect, rectList) {\n if(nrow(rectList)==0) {\n return(FALSE)\n }\n for (r in 1:nrow(rectList)) {\n # If rectangle has area 0, no overlap\n if (testRect$xmin == testRect$xmax || testRect$ymax == testRect$ymin || rectList[r,\"xmin\"] == rectList[r,\"xmax\"] || rectList[r,\"ymax\"] == rectList[r,\"ymin\"]) {\n next\n }\n \n # If one rectangle is on the left side of the other\n if (testRect$xmin > rectList[r,\"xmax\"] || rectList[r,\"xmin\"] > testRect$xmax) {\n next\n }\n \n # If one rectangle is above the other\n if (testRect$ymin > rectList[r,\"ymax\"] || rectList[r,\"ymin\"] > testRect$ymax) {\n next\n }\n return(TRUE)\n }\n return(FALSE)\n}\n\n# Create an empty data frame\ndf.new <- data.frame()\n\n# Iterate over each row of the original data frame\nfor(r in 1:nrow(df)) {\n # Select the rectangle from the original data frame\n testRect <- df[r,]\n \n # Calculate the height of the rectangle\n rect_height <- testRect$ymax - testRect$ymin\n \n # Set the minimum y-coordinate of the rectangle to 0\n testRect$ymin <- 0\n \n # Set the maximum y-coordinate of the rectangle based on the height\n testRect$ymax <- testRect$ymin + rect_height\n \n # Check if the rectangle overlaps with any existing rectangles in the new data frame\n while(overlaps_any(testRect, df.new)) {\n # Increment the y-coordinates of the rectangle by 1 to avoid overlap\n testRect$ymin <- testRect$ymin + 1\n testRect$ymax <- testRect$ymax + 1\n }\n \n # Append the updated rectangle to the new data frame\n df.new <- rbind(df.new, testRect)\n}\n\n# Plot the rectangles using ggplot\nprint(\n ggplot(df.new, aes(\n xmin = xmin,\n xmax = xmax,\n ymin = ymin,\n ymax = ymax\n )) +\n geom_rect(color = \"black\", fill = \"cyan\") + coord_fixed() + theme_void()\n)\n"} {"post_id":57823806,"creation_date":"2019-09-06 14:18:45","snippet":"library(provenance)\n\n#File \nA <- choose.files(multi = FALSE, filters = cbind(\"Files csv (*.csv)\", \"*.csv\"))\n\n#Read the file\nMP <- read.counts(A)\n\n#Plot\nT1 <- ternary(MP)\nplot(T1,labels=NULL)\n\n#Draw the ellipse\nternary.ellipse(T1, alpha=0.05, population=TRUE, col=\"Red\", lwd=3) #how to fill this ellipse?\n"} {"post_id":57810140,"creation_date":"2019-09-05 17:09:37","snippet":"x=1:7\ny=1:7\ndf = data.frame(x=x,y=y)\nbp <- vector(\"list\", length = 4)\nfor (i in 1:4) {\n bp[[i]] <- ggplot(df,aes(x,y))+geom_point()\n}\n"} {"post_id":57814984,"creation_date":"2019-09-06 02:25:03","snippet":"library(dbplyr)\nlibrary(DBI)\nlibrary(RMySQL)\nmy_db <- DBI::dbConnect(RMySQL::MySQL()(), \n host = \"127.0.0.1\",\n port = 3306,\n user = \"username\",\n password = \"password\"\n )\n\nemployee <- tbl(my_db, \"employee\")\n\nview(employee)\n"} {"post_id":57828822,"creation_date":"2019-09-06 21:42:10","snippet":"myList <- list()\ndf1 <- as.data.frame(matrix(1:6, nrow=3, ncol=2))\ndf2 <- as.data.frame(matrix(7:15, nrow=3, ncol=3))\nmyList[[1]]<-df1\nmyList[[2]]<-df2\nprint(myList)\n\n"} {"post_id":76596578,"creation_date":"2023-07-01 21:05:19","snippet":"file <- \"cdc.txt\"\n\ntext <- readLines(file)\n\nhtml <- paste(text, collapse = \"\\n\")\n\npattern1 <- '/web/\\\\d+/https://covid\\\\.cdc\\\\.gov/covid-data-tracker/[^\"]+'\n\nlinks <- regmatches(html, gregexpr(pattern1, html))[[1]]\n"} {"post_id":57822626,"creation_date":"2019-09-06 13:05:34","snippet":"library(grid)\n\n# Make dummy raster\nset.seed(1234)\nx <- cumsum(rnorm(10))\nx <- x %*% t(x)\nx <- scales::rescale(x)\n\ngrid.newpage()\ngrid.raster(x, interpolate = F,\n width = unit(1, \"npc\"),\n height = unit(1, \"npc\"))\n"} {"post_id":57822626,"creation_date":"2019-09-06 13:05:34","snippet":"df <- reshape2::melt(x)\n\n# Convert pixels to vertex coordinates\ncoords <- matrix(\n c(rep(df$Var1 - 0.5, 2),\n rep(df$Var1 + 0.5, 2),\n df$Var2 - 0.5, \n rep(df$Var2 + 0.5, 2),\n df$Var2 - 0.5),\n ncol = 2\n)\n\n# Rotate coordinates\nrotmat <- matrix(c(0.5, -1, 0.5, 1), ncol = 2)\ncoords <- t(rotmat %*% (t(coords)))\n\n# Re-assemble data\ndf <- rbind(df, df, df, df)\ndf$Var1 <- scales::rescale(coords[, 1])\ndf$Var2 <- scales::rescale(coords[, 2])\ndf$id <- rep(seq_len(length(x)), 4)\ndf <- df[order(df$id), ]\n\ngrid.newpage()\ngrid.rect(gp = gpar(col = \"red\")) # To illustrate boundaries\ngrid.polygon(\n x = df$Var1, y = df$Var2,\n id = df$id,\n gp = gpar(col = NA,\n fill = rgb(df$value, df$value, df$value)[!duplicated(df$id)])\n)\n"} {"post_id":57834130,"creation_date":"2019-09-07 13:29:08","snippet":"library(data.table)\nlibrary(tidyverse)\ntemp.dt <- data.table(a = 1:3, b = 1:3, c = 1:3)\nd <- 10\ntemp.dt %>% pmap_dfr(., sum, d) # add columns a b and c and add variable d to it\n"} {"post_id":76607184,"creation_date":"2023-07-03 18:00:30","snippet":"library(dplyr)\nset.seed(123)\n\nn_boot <- 1000\n\nboot_results2 <- matrix(NA, nrow = n_boot, ncol = 4)\ncolnames(boot_results2) <- c(\"P(H|H)\", \"P(T|H)\", \"P(H|T)\", \"P(T|T)\")\n\nfor (b in 1:n_boot) {\n\n print(b)\n \n\n boot_students <- sample(unique(final$student_id), replace = TRUE)\n \n\n boot_data <- data.frame(student_id = integer(0), coin_result = character(0), stringsAsFactors = FALSE)\n \n for (s in boot_students) {\n\n student_data <- final %>% filter(student_id == s)\n \n\n x <- sample(nrow(student_data), 1)\n y <- sample(x:nrow(student_data), 1)\n \n\n student_data <- student_data[x:y, ]\n \n\n boot_data <- rbind(boot_data, student_data)\n }\n \n\n p_hh <- mean(boot_data$coin_result[-1] == \"H\" & boot_data$coin_result[-nrow(boot_data)] == \"H\")\n p_th <- mean(boot_data$coin_result[-1] == \"H\" & boot_data$coin_result[-nrow(boot_data)] == \"T\")\n p_ht <- mean(boot_data$coin_result[-1] == \"T\" & boot_data$coin_result[-nrow(boot_data)] == \"H\")\n p_tt <- mean(boot_data$coin_result[-1] == \"T\" & boot_data$coin_result[-nrow(boot_data)] == \"T\")\n \n boot_results2[b, ] <- c(p_hh, p_th, p_ht, p_tt)\n}\n"} {"post_id":76607184,"creation_date":"2023-07-03 18:00:30","snippet":"library(ggplot2)\n\nboot_results_long2 <- as.data.frame(boot_results2)\nboot_results_long2$iteration <- 1:n_boot\nboot_results_long2 <- boot_results_long2 %>%\n gather(key = \"coin\", value = \"probability\", -iteration)\n\n\nggplot(boot_results_long2, aes(x = iteration, y = probability, color = coin)) +\n geom_line() +\n labs(x = \"Iteration\", y = \"Probability\", color = \"Coin\") +\n scale_color_discrete(labels = c(\"P(H|H)\", \"P(T|H)\", \"P(H|T)\", \"P(T|T)\"))\n"} {"post_id":76610259,"creation_date":"2023-07-04 07:29:03","snippet":"# set initial parameters\np = 1.2\nsigma = 1.88\nk <- c(0.55, 1.09, 0.62, 0.97)\nI = rnorm(len_id, 0, 0.01)\npar = c(p, sigma, k, I)\n\n# calculate the sum of likelihood with initial parameter values\nsum_negloglike(par) \n\n# estimate the parameters\noptim(par, sum_negloglike)\n"} {"post_id":57840037,"creation_date":"2019-09-08 07:45:06","snippet":"myurl <- \"https://collidr-api.s3-ap-southeast-2.amazonaws.com/pfd.RDS\"\n\ndownload.file(myurl, \"file.RDS\")\n# read into R\nreadRDS(\"file.RDS\")\n\n# Or similarly\ncurl::curl_download(myurl, \"file.RDS\")\n# read into R\nreadRDS(\"file.RDS\")\n"} {"post_id":76616594,"creation_date":"2023-07-05 01:26:14","snippet":"library(data.table)\nlibrary(profvis)\n\nset.seed(42)\n\n# Data to join\ndata1 <- function() {\n dt_1 <- as.data.table(matrix(rnorm(1e7 * 5), ncol = 5))\n dt_1[, join := sample.int(1e5, 1e7, replace = TRUE)]\n \n return(dt_1)\n}\n\ndata2 <- function() {\n dt_2 <- as.data.table(matrix(rnorm(1e5 * 5), ncol = 5))\n dt_2[, join := sample.int(1e5, 1e5)]\n setnames(dt_2, new = c(\"X1\", \"X2\", \"X3\", \"X4\", \"X5\", \"join\"))\n \n return(dt_2)\n}\n\n# Bench 2\ndt_1 <- data1()\ndt_2 <- data2()\n\nprofvis({\n dt_1[dt_2, on = .(join), (names(dt_2)) := mget(paste0(\"i.\", names(dt_2)))]\n})\n\n# Bench 3\ndt_1 <- data1()\ndt_2 <- data2()\n\nprofvis({\n dt_1[dt_2, on = .(join), \n `:=`(X1 = i.X1,\n X2 = i.X2,\n X3 = i.X3,\n X4 = i.X4,\n X5 = i.X5)]\n})\n"} {"post_id":57845331,"creation_date":"2019-09-08 19:59:43","snippet":"data$level <- as.factor(as.character(data$level))\ndata$reg_l <- with(data, paste(reg,level,sep = \"_\"))\n\ndata$org <- factor(data$org,levels=c(\"WR\",\"MS\",\"SM\",\"AA\",\"AAL\",\"PH\",\"P3\",\"SD\",\"HS\"))\n\n# plot\nreg_plot <- ggplot(data, aes(x = reorder(reg_l,share),y = share,group=org)) +\n coord_flip()+\n facet_wrap(level~.,ncol = 1,scales=\"free\") +\n geom_bar(stat=\"identity\",aes(fill=org),colour=NA,width=0.75) +\n scale_x_discrete(breaks = data$reg_l, labels = data$reg) +\n xlab(\"\\n\") + \n ylab(\"\\n\") +\n scale_y_continuous(limits = c(0,100)) +\n ggtitle(\"\\n\")\n\nreg_plot\n"} {"post_id":57842057,"creation_date":"2019-09-08 12:40:17","snippet":"library(tidyverse)\nlibrary(waffle)\nlibrary(gganimate)\n\ndata(\"mpg\")\nd <- mpg\n\nd$class <- as.factor(d$class)\nd$manufacturer <- as.factor(d$manufacturer)\n\nplot <- d %>% count(manufacturer, class) %>%\n ggplot(aes(fill = class, values = n)) +\n geom_waffle(color = \"white\",\n size = .75,\n n_rows = 4) +\n ggthemes::scale_fill_tableau(name = NULL) +\n coord_equal() +\n theme_minimal() +\n theme(panel.grid = element_blank(), axis.text = element_blank(), legend.position = \"bottom\")\n\n#Facet wrap works fine:\nplot + facet_wrap(~ manufacturer)\n\n#gganimate returns error:\nplot + transition_states(manufacturer, transition_length = 2, state_length = 2)\n\n\n"} {"post_id":57843139,"creation_date":"2019-09-08 15:08:11","snippet":"places = st_read(\"https://gist.githubusercontent.com/peeter-t2/9646a4169e993948fa97f6f503a0688b/raw/cb4e910bf153e51e3727dc9d1c73dd9ef86d2556/kih1897m.geojson\", stringsAsFactors = FALSE)\n\nschools <- read_tsv(\"https://gist.github.com/peeter-t2/34467636b3c1017e89f33284d7907b42/raw/6ea7dd6c005ef8577b36f5e84338afcb6c76b707/school_nums.tsv\")\nschools_geo <- merge(places,schools,by.x=\"KIHELKOND\",by.y=\"Kihelkond\") #94 matches\n\np<- schools_geo %>% \n ggplot()+\n geom_sf(data=schools_geo)+\n geom_sf(data=st_centroid(schools_geo),aes(size=value))+\n theme_bw()\np\n"} {"post_id":57861765,"creation_date":"2019-09-09 22:09:24","snippet":"library(ggcorrplot)\n\nmydata <- mtcars\n\n#correlation matrix\ncormat <- round(cor(mydata),2)\n\nlibrary(reshape2)\nmelted_cormat <- melt(cormat)\nhead(melted_cormat)\n\nlibrary(ggplot2)\nggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill=value)) + \n geom_tile()\n\n# Get upper triangle of the correlation matrix\nget_upper_tri <- function(cormat){\n cormat[lower.tri(cormat)]<- NA\n return(cormat)\n}\n\nupper_tri <- get_upper_tri(cormat)\n\n# Melt the correlation matrix\nlibrary(reshape2)\nmelted_cormat <- melt(upper_tri, na.rm = TRUE)\n# Heatmap\nlibrary(ggplot2)\nggplot(data = melted_cormat, aes(Var2, Var1, fill = value))+\n geom_tile(color = \"white\")+\n scale_fill_gradient2(low = \"blue\", high = \"red\", mid = \"white\", \n midpoint = 0, limit = c(-1,1), space = \"Lab\", \n name=\"Pearson\\nCorrelation\") +\n theme_minimal()+ \n theme(axis.text.x = element_text(angle = 45, vjust = 1, \n size = 12, hjust = 1))+\n coord_fixed()\n"} {"post_id":57863676,"creation_date":"2019-09-10 03:30:16","snippet":"x1 <- c(1:10)\nx2 <- c(1:10)\nx3 <- c(11:20)\nx <- data.frame(cbind(x1,x2,x3))\n\ny1 <- c(1:10)\ny2 <- c(1:10)\ny3 <- c(11:20)\ny <- data.frame(cbind(y1,y2,y3))\n\nz1 <- c(1:10)\nz2 <- c(1:10)\nz3 <- c(11:20)\nz <- data.frame(cbind(z1,z2,z3))\n"} {"post_id":57854980,"creation_date":"2019-09-09 13:25:23","snippet":"y1 <- Default$default\n\nbeta = coef(lasso.mod1, x=x1, y=y1, s=lambda/1000, exact=T)\ny1= ifelse(y1==\"NO\",0,1)\n\nout = fixedLassoInf(x1,(y1),beta,lambda,family=\"binomial\",alpha=0.05)\nout\n"} {"post_id":57871700,"creation_date":"2019-09-10 13:17:38","snippet":"## \n## load.libraries()\nsuppressMessages(library(shiny))\nsuppressMessages(library(plotly))\nsuppressMessages(library(tidyr))\nsuppressMessages(library(data.table))\nsuppressMessages(library(dplyr))\nsuppressMessages(library(lubridate))\nsuppressMessages(library(DT))\n\n##\n## Set global env values\n## Client\n.GlobalEnv$client <- \"STLevis\"\n## Data storage for message\n.GlobalEnv$vault <- \"message.txt\"\nif(!file.exists(vault)) fwrite(file=vault, data.frame(depoTime=as.POSIXct(character()),msg=character(),duration.h=character(),remTime=as.POSIXct(character())))\n.GlobalEnv$msg_vault_df <- fread(vault)\n\n##\n## colors\n.GlobalEnv$civ.col1 <- rgb(60/255, 60/255, 59/255)\n.GlobalEnv$civ.col2 <- rgb(145/255, 191/255, 39/255)\n.GlobalEnv$civ.axis.col <- list(linecolor = toRGB(\"lightgrey\"),\n gridcolor = toRGB(\"darkgrey\"),\n tickcolor = toRGB(\"darkgrey\"),\n tickfont = list(color=\"white\"),\n titlefont = list(color=\"white\"))\n\n\n\n###################################\n## Store the message with its duration\nstore.message <- function(myMessage,myDuration){\n ## Open the message vault\n msg_vault <- fread(vault)\n ## Change the column class\n msg_vault <- msg_vault %>% mutate(depoTime = as.character(depoTime),\n msg = as.character(msg), \n duration.h = as.numeric(duration.h), \n remTime = as.character(remTime))\n ## Create the data to save\n time.now <- Sys.time()\n new_data <- data.frame(depoTime = as.character(time.now),\n msg = myMessage,\n duration.h = myDuration,\n remTime = as.character(time.now + hours(myDuration)))\n ## Append the new message\n new_vault <- rbind(msg_vault,new_data)\n ## Save it\n fwrite(new_vault,file=vault)\n}\n\n###################################\n## Store the message with its duration\nstore.message.vault <- function(msg_vault){\n ## Remove the buttons\n msg_vault <- msg_vault %>% select(-Delete)\n ## Save it\n fwrite(msg_vault,file=vault)\n}\n"} {"post_id":57868849,"creation_date":"2019-09-10 10:27:53","snippet":"library(shiny)\nlibrary(shinyWidgets)\n\nui <- fluidPage(uiOutput(\"selItem\"))\n\nserver <- function(input, output, session)\n{\n global <- reactiveValues(itemNames=NULL, itemValues=NULL)\n\n observe(\n {\n options <- c(\"word01\", \"word02\", \"word03\", \"word04\", \"word05\", \"word06\", \"word07\", \"word08\", \"word09\", \"word10\", \"word11\", \"word12\", \"word13\", \"word14\", \"word15\", \"word16\", \"word17\", \"word18\", \"word19\", \"word20\", \"word21\", \"word22\", \"word23\", \"word24\", \"word25\", \"word26\", \"word27\", \"word28\", \"word29\", \"word30\", \"word31\", \"word32\", \"word33\", \"word34\", \"word35\", \"word36\",\"word37\", \"word38\", \"word38\", \"word39\", \"word40\", \"word41\", \"word42\", \"word43\", \"word44\", \"word45\", \"word46\", \"word47\")\n\n global$itemNames = options\n global$itemValues = options\n })\n\n output$selItem <- renderUI(\n {\n fluidRow(\n style = \"overflow-x: scroll;\",\n radioGroupButtons(inputId = \"replyItem\", label = NULL, choiceNames = global$itemNames, choiceValues = global$itemValues, selected = character(0), individual = TRUE, width = \"10000px\")\n )\n })\n\n observeEvent(input$replyItem,\n {\n index <- which(global$itemValues==input$replyItem)\n global$itemNames[index] <- HTML(paste0(\"\", global$itemValues[index], \"<\/span>\"))\n })\n}\n\nshinyApp(ui = ui, server = server)\n"} {"post_id":57867482,"creation_date":"2019-09-10 09:08:06","snippet":"library(shiny)\nlibrary(DT)\n\nui <- fluidPage(\n fluidRow(column(12, DTOutput(\"table\"))\n )\n)\n\nserver <- function(input, output, session) {\n output$table <- renderDT({\n\n DT::datatable(iris, filter = \"top\")\n })\n}\n\nshinyApp(ui, server)\n\n\n"} {"post_id":76623405,"creation_date":"2023-07-05 19:11:06","snippet":"library(shiny)\n# example app for bookmarking and restoring dynamically added tabs\n# only the last added tab is bookmarked. \n\nui <- function(request) {\n fluidPage(\n sidebarLayout(\n sidebarPanel(\n actionButton(\"add\", \"Add 'Dynamic' tab\"),\n actionButton(\"remove\", \"Remove selected tab\"), \n # Add a bookmarking buttons\n bookmarkButton(),\n actionButton(\"restore\", \"Restore State\")\n\n ),\n mainPanel(\n tabsetPanel(id = \"tabs\",\n tabPanel(\"Hello\", \"This is the hello tab\")\n )\n )\n )\n)\n}\n \nserver <- function(input, output, session) {\n observeEvent(input$add, {\n insertTab(inputId = \"tabs\",\n tabPanel(paste(\"Dynamic\",input$add), \"This a dynamically-added tab\")\n )\n })\n \n observeEvent(input$remove, {\n removeTab(inputId = \"tabs\", target = input$tabs)\n })\n \n onBookmarked(function(url) {\n updateQueryString(url)\n })\n \n observeEvent(input$restore, {\n session$reload() \n }) \n}\n\nenableBookmarking(store = \"url\")\nshinyApp(ui, server)\n"} {"post_id":19868839,"creation_date":"2013-11-08 21:29:50","snippet":"data[with(data, order(year)),];\nsale_data <- diff(data$SALE);\ndata <- data[-1,];\ndata$SALE <- sale_data;\nreturn(data)\n"} {"post_id":19868839,"creation_date":"2013-11-08 21:29:50","snippet":"a <- data.frame();\nkey <- c(1,1,1,1,2,2,2,2,2,3,3,3);\nsales <- c(12,12,15,8,3,6,3,9,9,12,3,7);\nyear <- c(2002,2003,2004,2005,2001,2002,2003,2004,2005,2003,2004,2005);\novar <- runif(12,5.0,7.5);\na <- data.frame(key,sales,year,ovar)\n"} {"post_id":58165226,"creation_date":"2019-09-30 09:39:55","snippet":"image_links = data.frame(id = c(1,2,3,4,5),\n image = c(\"https://cdn.shopify.com/s/files/1/1061/1924/products/Smiling_Emoji_with_Eyes_Opened_large.png\",\n \"https://cdn.shopify.com/s/files/1/1061/1924/products/Smiling_Emoji_with_Smiling_Eyes_large.png\",\n \"https://cdn.shopify.com/s/files/1/1061/1924/products/Hushed_Face_Emoji_large.png\",\n \"https://cdn.shopify.com/s/files/1/1061/1924/products/Disappointed_but_Relieved_Face_Emoji_large.png\",\n \"https://cdn.shopify.com/s/files/1/1061/1924/products/Expressionless_Face_Emoji_large.png\"))\n\n\nmydata = data.frame(x = rnorm(100, mean = 50, sd = 20),\n y = rnorm(100, mean = 50, sd = 5),\n id = rep(c(1,2,3,4,5), 20))\n\nmydata$y = mydata$y - 10*mydata$id\n\nmydata = mydata %>% left_join(image_links, by='id')\n\ng <- ggplot(mydata) + geom_image(aes(x=x, y=y, image=image), size=0.05)\n\nggsave(g, filename='[INSERT PATH HERE].png', width=width, height=height, dpi=300)\n"} {"post_id":20363257,"creation_date":"2013-12-03 22:45:15","snippet":"require(XML)\n\ndir.create(\"D:/GIS_DataBase/DEM/\")\nsetwd(\"D:/GIS_DataBase/DEM/\")\n\ndoc <- htmlParse(\"http://www.viewfinderpanoramas.org/dem3.html#alps\")\nurls <- paste0(\"http://www.viewfinderpanoramas.org\", xpathSApply(doc,'//*/a[contains(@href,\"/dem1/N4\")]/@href'))\nnames <- gsub(\".*dem1/(\\\\w+\\\\.zip)\", \"\\\\1\", urls)\n\nfor (i in 1:length(urls)) download.file(urls[i], names[i])\n"} {"post_id":39778955,"creation_date":"2016-09-29 19:57:43","snippet":"library(KFAS)\n\nset.seed(100)\n\neps <- rt(200, 4, 1)\nmeas <- as.matrix((arima.sim(n=200, list(ar=0.6), innov = rnorm(200)*sqrt(0.5)) + eps), \nncol=1)\n\nZt <- 1\nHt <- matrix(NA)\nTt <- matrix(NA)\nRt <- 1\nQt <- matrix(NA)\n\nss_model <- SSModel(meas ~ -1 + SSMcustom(Z = Zt, T = Tt, R = Rt, \n Q = Qt), H = Ht)\nfit <- fitSSM(ss_model, inits = c(0,0.6,0), method = 'L-BFGS-B')\n"} {"post_id":21158347,"creation_date":"2014-01-16 09:49:50","snippet":"library(ggplot2)\nlibrary(gridExtra)\n\nx = read.table(text = \"\n 1/1/2010 10\n 1/2/2010 20\n 1/3/2010 15\n 1/4/2010 56\n 1/5/2010 46\n 1/6/2010 15\n 1/8/2010 15\n 1/9/2010 15\n 1/10/2010 20\n 1/11/2010 15\n 1/12/2010 15\n 1/13/2010 40\n 1/14/2010 15\n 1/15/2010 15\n 1/16/2010 70\", sep = \"\", header = FALSE)\n\np1<-ggplot(x, aes(V2, V1)) + geom_point()\np2<-tableGrob(x)\n\npng( filename = \"TEST.png\", width = 1700, height = 900, units = \"px\")\ngrid.arrange(p2, p1, main=textGrob(\"Total Data and Image\", gp=gpar(cex=3)), \n ncol = 2,widths=unit.c(grobWidth(p2), unit(1,\"npc\") - grobWidth(p2)))\ndev.off()\n"} {"post_id":40486741,"creation_date":"2016-11-08 12:16:23","snippet":"Final = structure(list(Subject = structure(c(1L, 1L, 1L, 1L, 1L, 1L, \n1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, \n3L, 3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 5L, 5L, 5L, 5L, 5L, 5L, \n5L, 5L), .Label = c(\"1\", \"2\", \"3\", \"4\", \"5\"), class = \"factor\"), \n X00.conditionName = structure(c(1L, 1L, 2L, 2L, 3L, 3L, 4L, \n 4L, 1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 1L, 1L, 2L, 2L, 3L, 3L, \n 4L, 4L, 1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L, 1L, 1L, 2L, 2L, 3L, \n 3L, 4L, 4L), .Label = c(\"EyeClose-Haptic\", \"mixed-Haptic_Visual\", \n \"only-Haptic\", \"only-Visual\"), class = \"factor\"), X03.totalTargetNumber = c(2L, \n 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, \n 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, \n 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L), Accuracy = c(0.075870763, \n 0.0907863686, 0.0222156611, 0.0492028585333333, 0.0301178471, \n 0.0736098328666667, 0.0329723832, 0.0455095300666667, 0.065151615, \n 0.0979033533333333, 0.0247176775, 0.0335825226666667, 0.027385248, \n 0.0462643053333333, 0.037272505, 0.0652166726666667, 0.043005086, \n 0.061848328, 0.031106749, 0.0275656054, 0.026701889, 0.0373967466666667, \n 0.028998468, 0.03219287, 0.0597213356, 0.0851717708333333, \n 0.030286913, 0.0779058462666667, 0.043368508, 0.051437624, \n 0.029002474, 0.0479204566666667, 0.094555739, 0.0856268291666667, \n 0.031908514, 0.0310441326666667, 0.036311762, 0.0496942306666667, \n 0.054625148, 0.0482682121666667), upperCI = c(0.116082073022708, \n 0.139632763787946, 0.0315087794760623, 0.0727058964327625, \n 0.0468512606854127, 0.116787586356955, 0.0444933233012107, \n 0.062820743812494, 0.0858551911272202, 0.136013260005381, \n 0.0327074347874691, 0.0460471773903695, 0.035302995136302, \n 0.0740077338495226, 0.0641795522210299, 0.131047110446756, \n 0.0572545979325947, 0.0809511078363974, 0.0414215170576924, \n 0.0341480438532189, 0.0382253716300962, 0.0519626825555577, \n 0.0377955915789704, 0.0430125127419472, 0.0903928001427357, \n 0.114245467448517, 0.0461054194398361, 0.129350863514659, \n 0.0635159480110737, 0.0717647837071829, 0.0371919026867606, \n 0.0615899295823839, 0.170222051412597, 0.128502458351433, \n 0.046712862081242, 0.0388340720489338, 0.0574188259607336, \n 0.0786845830951613, 0.0844193698576058, 0.0784830058409822\n ), lowerCI = c(0.0356594529772922, 0.0419399734120541, 0.0129225427239377, \n 0.0256998206339042, 0.0133844335145873, 0.0304320793763786, \n 0.0214514430987893, 0.0281983163208393, 0.0444480388727798, \n 0.059793446661286, 0.0167279202125309, 0.0211178679429639, \n 0.019467500863698, 0.0185208768171441, 0.0103654577789701, \n -0.000613765113422152, 0.0287555740674053, 0.0427455481636026, \n 0.0207919809423076, 0.0209831669467811, 0.0151784063699038, \n 0.0228308107777757, 0.0202013444210296, 0.0213732272580528, \n 0.0290498710572643, 0.0560980742181497, 0.0144684065601638, \n 0.0264608290186746, 0.0232210679889263, 0.0311104642928171, \n 0.0208130453132394, 0.0342509837509495, 0.018889426587403, \n 0.0427511999819006, 0.017104165918758, 0.0232541932843995, \n 0.0152046980392664, 0.0207038782381721, 0.0248309261423941, \n 0.0180534184923511), CondLevel = c(\"EyeClose-Haptic2\", \"EyeClose-Haptic3\", \n \"mixed-Haptic_Visual2\", \"mixed-Haptic_Visual3\", \"only-Haptic2\", \n \"only-Haptic3\", \"only-Visual2\", \"only-Visual3\", \"EyeClose-Haptic2\", \n \"EyeClose-Haptic3\", \"mixed-Haptic_Visual2\", \"mixed-Haptic_Visual3\", \n \"only-Haptic2\", \"only-Haptic3\", \"only-Visual2\", \"only-Visual3\", \n \"EyeClose-Haptic2\", \"EyeClose-Haptic3\", \"mixed-Haptic_Visual2\", \n \"mixed-Haptic_Visual3\", \"only-Haptic2\", \"only-Haptic3\", \"only-Visual2\", \n \"only-Visual3\", \"EyeClose-Haptic2\", \"EyeClose-Haptic3\", \"mixed-Haptic_Visual2\", \n \"mixed-Haptic_Visual3\", \"only-Haptic2\", \"only-Haptic3\", \"only-Visual2\", \n \"only-Visual3\", \"EyeClose-Haptic2\", \"EyeClose-Haptic3\", \"mixed-Haptic_Visual2\", \n \"mixed-Haptic_Visual3\", \"only-Haptic2\", \"only-Haptic3\", \"only-Visual2\", \n \"only-Visual3\")), .Names = c(\"Subject\", \"X00.conditionName\", \n\"X03.totalTargetNumber\", \"Accuracy\", \"upperCI\", \"lowerCI\", \"CondLevel\"\n), row.names = c(NA, -40L), class = \"data.frame\")\n\n\nrequire(ggplot2)\n\npdf(\"Pilot2.pdf\", w = 12, h = 8)\nlimits <- aes(ymax = upperCI, ymin=lowerCI)\nBaseLayer = ggplot(data = Final, aes (x = X00.conditionName, y = Accuracy, color = Subject, group = Subject ))\nBaseLayer + geom_pointrange(limits, position=position_dodge(width=1), size = 1.5) + \ntheme(axis.text=element_text(size=14), axis.title=element_text(size=14), axis.text.x = element_text(angle = 25, hjust = 1)) + \nfacet_grid (.~X03.totalTargetNumber) + ggtitle (\"Pilot 2\") + xlab (\"Condition\")\ndev.off()\n"} {"post_id":40821591,"creation_date":"2016-11-26 18:22:44","snippet":"library(cluster)\nlibrary(factoextra)\n\n\n#read data\ndata<-read.csv(\"..\\file.txt\",header=FALSE, sep=\" \")\n\n#determine number of clusters to use\nk.max<- 22\nwss <- sapply(2:k.max, function(k){kmeans(data, k, nstart=10 )$tot.withinss})\n\nprint(wss)\n\nplot(2:k.max, wss, type=\"b\", pch = 19, xlab=\"Number of clusters K\", ylab=\"Total within-clusters sum of squares\")\n\n\nfviz_nbclust(data, kmeans, method = \"wss\") + geom_vline(xintercept = 3, linetype = 2)\n"} {"post_id":60879460,"creation_date":"2020-03-27 03:09:07","snippet":"library(sf)\nlibrary(rnaturalearth)\nlibrary(ggplot2)\n\n#get basic world map \nworld = ne_coastline(scale = \"medium\", returnclass = \"sf\")\n\n#example 1: without dateline\n#minimal data- two points on one side of dateline\nsites = data.frame(longitude = c(-173.9793, -177.7405), latitude = c(52.21415, 51.98994))\n\n#convert to sf object\nsites = st_as_sf(sites, coords = c(\"longitude\", \"latitude\"), crs = 4326)\n\n#plot with ggplot\nggplot()+\n geom_sf(data = world, fill = 'transparent')+\n geom_sf(data = sites)+\n #set the limits for the plot\n coord_sf(crs = 4326,\n xlim = c(min(st_coordinates(sites)[,1]) -1, max(st_coordinates(sites)[,1])+1),\n ylim = c(min(st_coordinates(sites)[,2]) -1, max(st_coordinates(sites)[,2])+1))+\n labs(title = 'data on one side of dateline only- looks good')+\n theme_bw()\n\n\n#example 2: with dateline\n#deal with dateline using st_shift_longitude \nworld_2 = st_shift_longitude(world)\n\n#minimal data- a point on each side of dateline\nsites_2 = data.frame(longitude = c(-173.9793, 177.7405), latitude = c(52.21415, 51.98994))\n\n#convert to sf object\nsites_2 = st_as_sf(sites_2, coords = c(\"longitude\", \"latitude\"), crs = 4326)\n#and deal with dateline using st_shift_longitude \nsites_2 = st_shift_longitude(sites_2)\n\n#plot with ggplot\nggplot()+\n geom_sf(data = world_2, fill = 'transparent')+\n geom_sf(data = sites_2)+\n #set the limits for the plot\n coord_sf(crs = 4326,\n xlim = c(min(st_coordinates(sites_2)[,1]) -1, max(st_coordinates(sites_2)[,1])+1),\n ylim = c(min(st_coordinates(sites_2)[,2]) -1, max(st_coordinates(sites_2)[,2])+1))+\n labs(title = 'data on both sides of dateline - grid wrong')+\n theme_bw()\n\n#plot with manually expanded limits- graticule works\nggplot()+\n geom_sf(data = world_2, fill = 'transparent')+\n geom_sf(data = sites_2)+\n #set the limits for the plot\n coord_sf(crs = 4326,\n xlim = c(175, 195),\n ylim = c(min(st_coordinates(sites_2)[,2]) -1, max(st_coordinates(sites_2)[,2])+1))+\n labs(title = 'data on both sides of dateline - manually expand x lims')+\n theme_bw()\n\n\n\n"} {"post_id":41895432,"creation_date":"2017-01-27 13:46:29","snippet":"df <- data.frame(matrix(rnorm(20), 10, 2),\n ids = paste(\"i\", 1:20, sep = \"\"),\n stringsAsFactors = FALSE)\n\n# works\ndplyr::select(df, - ids) %>% {rowSums(.)}\n\n# does not work\n# Error: invalid argument to unary operator\ndf %>%\n dplyr::mutate(blubb = dplyr::select(df, - ids) %>% {rowSums(.)})\n\n# does not work\n# Error: invalid argument to unary operator\ndf %>%\n dplyr::mutate(blubb = dplyr::select(., - ids) %>% {rowSums(.)})\n\n# workaround:\ntmp <- dplyr::select(df, - ids) %>% {rowSums(.)}\ndf %>%\n dplyr::mutate(blubb = tmp)\n\n# works\nrowSums(dplyr::select(df, - ids))\n\n# does not work\n# Error: invalid argument to unary operator\ndf %>%\n dplyr::mutate(blubb = rowSums(dplyr::select(df, - ids)))\n\n# workaround\ntmp <- rowSums(dplyr::select(df, - ids))\ndf %>%\n dplyr::mutate(blubb = tmp)\n"} {"post_id":23579012,"creation_date":"2014-05-10 08:49:47","snippet":"x <- c(1,3,5,2,4,6,7,9,8,10)\nsort(x)\n## [1] 1 2 3 4 5 6 7 8 9 10\nsort(x, partial=5)\n## [1] 1 3 4 2 5 6 7 9 8 10\nsort(x, partial=2)\n## [1] 1 2 5 3 4 6 7 9 8 10\nsort(x, partial=4)\n## [1] 1 2 3 4 5 6 7 9 8 10\n"} {"post_id":24006361,"creation_date":"2014-06-03 02:51:12","snippet":"landscape = MakeHexLattice(nx=nx,ny=ny,dist=dist,origin=c(0,0))\n\n# Plot hexagonal lattice as points\nplot(x=landscape[,2],y=landscape[,3], pch=19, col=\"black\", cex=0.5, asp=1/1)\n\n# Separate x and y coordinates\nlx = landscape[,2] # x-coordinates\nly = landscape[,3] # y-coordinates \n\n# Plot hexagonal lattice as filled hexagons\nhex.x = cbind(lx + 0, lx + 0.5, lx + 0.5, lx + 0, lx - 0.5, lx - 0.5) \nhex.y = cbind(ly - 1/(sqrt(3)), ly - 1/(2*sqrt(3)), ly + 1/(2*sqrt(3)), ly + 1/(sqrt(3)), ly + 1/(2*sqrt(3)), ly - 1/(2*sqrt(3)))\nhex.vectors = cbind(hex.x, hex.y)\n\nfor(i in 1:(length(hex.vectors)/12)){\n polygon(x=hex.vectors[i,1:6], y=hex.vectors[i,7:12], angle = 120, border=NULL, col=\"wheat\", \n lty = par(\"lty\"), fillOddEven = FALSE)\n}\n"} {"post_id":42678858,"creation_date":"2017-03-08 18:14:17","snippet":"set.seed(1001)\nN <- 1000\nG <- 10\ndd <- data_frame(x=runif(N),\n f=factor(sample(1:G,size=N,replace=TRUE)),\n y=rnorm(N)+2*x+as.numeric(f))\nm1 <- lm(y~x,data=dd)\ndda <- cbind(augment(m1),f=dd$f)\n"} {"post_id":61734306,"creation_date":"2020-05-11 16:15:10","snippet":"m4_test <- polr(WHOWINS ~ H_NUMBER_RED + A_NUMBER_RED + H_Pts_Percentage_EUR + A_Pts_Percentage_EUR,data=basetable4_reg, Hess=TRUE)\n#Get the p-values\n#Store the coefficient table\nm4.coef_test <- data.frame(round(coef(summary(m4_test)),5))\n#Calculate and store p values\nm4.coef_test$pval <- pnorm(abs(m4.coef_test$t.value),lower.tail=F)*2\nm4.coef_test\n#Visualize table\nstargazer(m4_test,type=\"html\",out=\"m4_test.htm\")\n"} {"post_id":61734306,"creation_date":"2020-05-11 16:15:10","snippet":"basetable4_reg_num <- basetable4_reg\nbasetable4_reg_num$WHOWINS <- as.numeric(levels(basetable4_reg_num$WHOWINS))[basetable4_reg_num$WHOWINS]\n#Last assumption: proportional odds\n#The relationship between each pair of outcome groups has to be the same\nsf <- function(y) {\n c('Y>=0' = qlogis(mean(y >= 0)),\n 'Y>=1' = qlogis(mean(y >= 1)),\n 'Y>=2' = qlogis(mean(y >= 2)))\n}\n\n#Filter out some unusual matches (8yellows,3 reds for 1 team)\nbasetable4_reg_num <- dplyr::filter(basetable4_reg_num, H_NUMBER_YELLOW != 8 & A_NUMBER_YELLOW != 8 & H_NUMBER_RED != 3 & A_NUMBER_RED != 3)\n(s4 <- with(basetable4_reg_num, summary(WHOWINS ~ spi1 + spi2 + H_NUMBER_YELLOW + H_NUMBER_RED + A_NUMBER_YELLOW + A_NUMBER_RED + H_cluster_2 + A_cluster_2 +\n H_cluster_3 + A_cluster_3 + H_Pts_Percentage_EUR + A_Pts_Percentage_EUR + H_STRONG_OPPONENT + \n A_STRONG_OPPONENT + Rest_Difference_EUR + H_FORM_EUR + A_FORM_EUR + H_break_EUR + A_break_EUR + \n H_START_H_EUR + A_START_H_EUR + H_carryover_EUR + A_carryover_EUR + H_SPI_First5 + A_SPI_First5, fun=sf)))\n\ns4[, 4] <- s4[, 4] - s4[, 3]\ns4[, 3] <- s4[, 3] - s4[, 3]\ns4\nplot(s4, which=1:3, pch=1:3, xlab='logit', main=' ',xlim=range(s4[,3:4]))\n\n"} {"post_id":24828498,"creation_date":"2014-07-18 15:19:24","snippet":"ggplot(rmm, aes(x=timestamp, y=value, color=serviceInstanceName, group=serviceInstanceName)) \n+ stat_smooth(size=1.5, method = \"loess\", level = 0.95, fullrange = TRUE, se = FALSE)\n+ scale_x_datetime(breaks = date_breaks(\"1 day\"), labels = date_format(\"%a/%m\"))\n+ theme(axis.text.x = element_text(angle = 90, hjust = 1)) + xlab(\"Day\") \n+ ylab(\"Utility\") + ggtitle(\"Utility Trend\")\n"} {"post_id":42882018,"creation_date":"2017-03-19 01:45:42","snippet":"snow <- read.csv(\"https://gist.githubusercontent.com/smach/d4188d200b465cba822405c323f1501c/raw/58c3785c34304ccc5dbcef632d3acb9d6dbad40c/BosChiNYCsnowfalls.csv\", stringsAsFactors = FALSE)\nlibrary(\"highcharter\")\n\nhcoptslang <- getOption(\"highcharter.lang\")\nhcoptslang$thousandsSep <- \",\"\noptions(highcharter.lang = hcoptslang)\n\nhighchart() %>%\n hc_chart(type = \"line\") %>%\n hc_title(text = \"Snowfall\") %>%\n hc_xAxis(categories = snow$Winter) %>%\n hc_add_series(data = snow$Boston * 10, name = \"Boston\") %>%\n hc_yAxis(labels = list(format = \"{value:,.0f}\"))\n"} {"post_id":24348065,"creation_date":"2014-06-22 04:15:13","snippet":"library(data.table)\nlibrary(svmpath)\n# Loaded svmpath 0.953\n\nfeatures <- data.table(matrix(runif(100000*16),ncol=16))\nlabels <- (runif(100000) > 0.7)\nsvmpath(x=features,y=labels)\n# Error in x %*% t(y) : requires numeric/complex matrix/vector arguments\nsvmpath(x=as.matrix(features),y=labels)\n# Error: cannot allocate vector of size 74.5 Gb\n\nlibrary(kernlab)\nksvm(as.matrix(features),y=labels,kernel=vanilla)\n# runs\n"} {"post_id":43102554,"creation_date":"2017-03-29 19:29:46","snippet":"library(shiny)\nlibrary(data.table)\n\nRegData <- as.data.table(read.table(\"/home/r2uphp/ShinyApps/IRViews/RegData.tsv\", header = TRUE, stringsAsFactors = FALSE))\n\nui <- fluidPage(\n headerPanel(\"Regression and Time Series Analysis\"), \n sidebarPanel(\n p(\"Select the inputs for the Dependent Variable\"),\n selectInput(inputId = \"DepVar\", label = \"Dependent Variables\", multiple = FALSE, choices = list(\"AvgIR\", \"YYYYMM\", \"SumCount\", \"AvgLTV\", \"AvgGFEE\", \"AvgRTC\", \"Date\")),\n p(\"Select the inputs for the Independent Variable\"),\n selectInput(inputId = \"IndVar\", label = \"Independent Variables\", multiple = FALSE, choices = list( \"SumCount\", \"AvgIR\", \"YYYYMM\", \"AvgLTV\", \"AvgGFEE\", \"AvgRTC\", \"Date\"))\n ),\n mainPanel(\n verbatimTextOutput(outputId = \"RegSum\"),\n verbatimTextOutput(outputId = \"IndPrint\"),\n verbatimTextOutput(outputId = \"DepPrint\")\n #plotOutput(\"hist\")\n )\n)\n\nserver <- function(input, output) {\n\n lm1 <- reactive({lm(paste0(input$DepVar) ~ paste0(input$IndVar), data = RegData)})\n\n output$DepPrint <- renderPrint({input$DepVar})\n output$IndPrint <- renderPrint({input$IndVar})\n output$RegSum <- renderPrint({summary(lm1())})\n\n}\n\nshinyApp(ui = ui, server = server)\n"} {"post_id":44118416,"creation_date":"2017-05-22 17:02:03","snippet":"pi <- 3.142\ne <- 2.718\nphi <- 1.618\ndf <- data.frame(pi, e, phi)\ndf\n# pi e phi\n# 1 3.142 2.718 1.618\n"} {"post_id":43333065,"creation_date":"2017-04-10 21:20:32","snippet":"ID <- as.factor(c(123,456,789))\nScore <- c(5,1,0)\nNew.ID<- as.factor(c(456, 789, 123))\nNew.Score <- c(1,0,5)\ndt <- data.frame(ID, Score, New.ID, New.Score)\n"} {"post_id":62700258,"creation_date":"2020-07-02 15:48:22","snippet":"library(shiny)\nlibrary(leaflet)\n\nui <- fluidPage(\n sidebarLayout(\n sidebarPanel(\n selectInput(\"color\", \"Color\", choices = c(\"red\", \"blue\", \"yellow\", \"green\"))\n ),\n mainPanel(\n tabsetPanel(\n tabPanel(\"Other\", h1(\"Empty Tab 1\")),\n tabPanel(\"Map\", leafletOutput(\"map\"))\n )\n )\n )\n)\n\nserver <- function(input, output, session) {\n # the base map and the circles are separated due to data restrictions\n # in the actual app!\n output$map <- renderLeaflet({\n leaflet() %>% \n addTiles()\n })\n observe({\n leafletProxy(\"map\") %>% \n addCircles(lng = 0, lat = 0, radius = 3e6, color = input$color)\n })\n}\n\nshinyApp(ui, server)\n"} {"post_id":24828341,"creation_date":"2014-07-18 15:10:50","snippet":"ggp <- ggplot(polys, aes(x = xvals, y = yvals)) + \n #geom_polygon(aes(fill = - value, group = id, alpha = value)) + # lovely blue\n geom_polygon(aes(fill = value, group = id, alpha = value)) + # lovely shiny light blue middle draw me in\n scale_x_log10(breaks = xaxtickpos, minor_breaks = NULL) + \n theme(legend.position = \"none\", panel.background = element_rect(fill = \"grey85\", colour = NA)) + \n xlab(\"maturity\") + ylab(\"bps\")\nggp <- ggp + geom_line(data = quanmelt[quanmelt[, \"percentile\"] %in% outerthresh, ], \n aes(x = mat, y = value, group = percentile), colour = \"white\", size = 2)\nggp <- ggp + geom_line(data = quanmelt[quanmelt[, \"percentile\"] %in% innerthresh, ], \n aes(x = mat, y = value, group = percentile), colour = \"white\", size = 1, \n linetype = \"dotted\")\n#add last few days line/today (this doesn't work very well hence commented out)\ntodayback <- todayline[todayline$daysback == 2, ] # get this historic lines\nggp <- ggp + geom_smooth(data = todayback, aes(x = mat, y = value, group = daysback), \n colour = \"darkred\", linetype = \"dashed\", \n se = FALSE, size = 1, method = \"loess\", span = (ifelse(smooth, 0.3, 0.1)))\n#add boxplot\nggp <- ggp + geom_boxplot(data = meltcdlong, aes(x = mat, y = value, group = bond), outlier.size = NA, \n colour = \"grey30\", alpha = 0.5, size = 0.2, width = 0.025)\n\n# add the latest point\nggp <- ggp + geom_point(data = latestcdpoint, aes(x = mat, y = value, group = bond)) \n# now do labels (twice - one for above, one for below)\nggp <- ggp + geom_text(data = latestcdpoint[latestcdpoint$adjustvertvec == 1, ], aes(x = mat, y = labelposies, label = label), \n angle = 90, colour = \"grey20\", size = 3, hjust = 0, alpha = 0.5)\nggp <- ggp + geom_text(data = latestcdpoint[latestcdpoint$adjustvertvec == 0, ], aes(x = mat, y = labelposies, label = label), \n angle = 90, colour = \"grey20\", size = 3, hjust = 1, alpha = 0.5)\n#now print a nice z-score graded colour line for the curve \ntodaytoday <- todayline[todayline$daysback == 0, ]\nminz <- min(rescale(todaytoday[, \"zscore\"])) # for scaling of z-score line gradient colours\nmaxz <- max(rescale(todaytoday[, \"zscore\"]))\nbpspline <- smooth.spline(todaytoday$mat, todaytoday$value, spar = 0.4) # Smooth out the curve with lots of points\nzscorespline <- smooth.spline(todaytoday$mat, todaytoday$zscore) # and smooth out the zscores too\nxplot <- seq(2, maxmat, by = 0.1)\ntodayplotter <- data.frame(mat = xplot, value = predict(bpspline, xplot)$y, \n zscore = rescale(c(-5, 5, predict(zscorespline, xplot)$y))[-1:-2]) # build the plotter\nggp <- ggp + geom_path(data = todayplotter, aes(x = mat, y = value, colour = zscore), size = 2, linejoin = \"bevel\") +\n scale_colour_gradientn(colours = gradientcolours, values = gradientscale, limits = c(minz, maxz))\n#and the title\nggp <- ggp + ggtitle(cCode)\n# now the test chart\nmm <<- meltcdrecent[meltcdrecent$daysback == 0, ]\nggp <- ggp + geom_point(data = mm, aes(x = mat, y = value, colour = rescale(c(-5, 5, zscore))[-1:-2]), size = 6) +\n scale_colour_gradientn(colours = gradientcolours, values = gradientscale, limits = c(0, 1))\nggp <- ggp + geom_point(data = mm, aes(x = mat, y = value), colour = \"black\", size = 4.5)\nggp <- ggp + geom_text(data = mm, aes(x = mat, y = value), label = round(mm$zscore, 1), colour = \"white\", size = 2, alpha = 0.7)\n"} {"post_id":65402764,"creation_date":"2020-12-22 03:09:30","snippet":"library(doParallel)\nlibrary(slurmR)\n\ncl <- makeSlurmCluster(4)\n\nregisterDoParallel(cl)\nm <- matrix(rnorm(9), 3, 3)\nforeach(i=1:nrow(m), .combine=rbind)\n\nStopCluster(cl)\nprint(m)\n"} {"post_id":44643930,"creation_date":"2017-06-20 04:37:18","snippet":" library(animation)\n donorm = function(k){\n require(ggplot2)\n Ns = matrix(0, 1000, k)\n X = matrix(0, 1000, k)\n for (i in 1:k){\n X[, i] = sort(rnorm(1000, mean = ifelse(i<11,0,2), sd = 0.5*ifelse(i<11,sqrt(i), sqrt(i -10))))\n Ns[, i] = dnorm(X[,i], mean = ifelse(i<11,0, 2), sd = 0.5*ifelse(i<11,sqrt(i), sqrt(i -10)))\n }\n mx = c(min(X), max(X))\n my = max(Ns)\n dat = data.frame(x = rep(0, 1000), y = rep(0, 1000))\n for (i in 1:k){\n dat$x = X[,i]; dat$y = Ns[,i]\n pl = ggplot2::ggplot(dat, aes(x = x, y= y)) + geom_line(color = i%%5 + 1, size = 1.5) + \n coord_cartesian(xlim = mx, ylim = c(0, my)) +\n annotate(\"text\", x = mx[1]+0.25, y = my[2]-0.25, label = \n paste(\"mean = \", round(ifelse(i<11,0,2),1),\"//st.dev = \", round(0.5*ifelse(i<11,sqrt(i), sqrt(i -10)), 1))) +\n theme_bw()\n print(pl)\n }\n }\n\n## this is suggested solution for calling convert.exe but it fails on my system\n# path_to_convert <- paste0(shortPathName(\"C:\\\\Program Files\\\\ImageMagick-7.0.6-Q16\\\\\"), \"convert.exe\")\n\n## this would work were the exe there\npath_to_convert = \"\\\"C:\\\\Program Files\\\\ImageMagick-7.0.6-Q16\\\\convert.exe\\\"\"\n\nanimation::ani.options(interval = 0.12, ani.width = 480, ani.height = 320, convert=path_to_convert)\nanimation::saveGIF(donorm(20), movie.name = paste0(\"Normals\",1,\"_Ani.gif\"))\n"} {"post_id":44643961,"creation_date":"2017-06-20 04:41:13","snippet":"library(tm)\ncrude <- \"japan korea usa uk albania azerbaijan\"\ncorps <- Corpus(VectorSource(crude))\ndtm <- DocumentTermMatrix(corps)\ninspect(dtm)\n\nwords <- c(\"australia\", \"korea\", \"uganda\", \"japan\", \"argentina\", \"turkey\")\ntest <- DocumentTermMatrix(corps, control=list(dictionary = words))\ninspect(test)\n"} {"post_id":27990236,"creation_date":"2015-01-16 18:15:20","snippet":"data <- read.csv(\"CSM Tiers by Org.csv\", stringsAsFactors = FALSE, na.strings = \"?\")\nx <- model.matrix(~ data$CSM + data$Exclude + data$Queue)\ny <- data$Time\nstatus <- data$Event\nglmnet(x,Surv(y,status), family = \"cox\")\n"} {"post_id":46094228,"creation_date":"2017-09-07 10:37:35","snippet":"#ui\nlibrary(shiny)\nlibrary(rCharts)\n\nshinyUI(bootstrapPage(\n div(\n class=\"container-fluid\",\n div(class=\"row-fluid\",\n headerPanel(\"Path Explorer\") \n ),\n div(class=\"row-fluid\",\n sidebarPanel(\n h4(\"Sankey Visualisation\")\n ),\n mainPanel(\n tableOutput(\"table\"),\n showOutput('sankey' ,'C:/Users/neha.sharma/Desktop/rCharts_d3_sankey-gh-pages/libraries/widgets/d3_sankey') # I refer to this directory later on in this message\n )\n )\n )\n))\n\n\n#server\n\nlibrary(shiny)\nlibrary(rCharts)\n\nshinyServer(function(input, output){\n data <- reactive({\n data <- data.frame(\n source = c(\"peugot\",\"Tagesschau.de\",\"BMW.DE\",\"DirectExit\",\"Amazon.de\",\"Google.com\",\"BMW.DE\",\"BMWgroup.com\",\"facebook\",\"directaccess\",\"BMW.DE\",\"Peugot\",\"bing1\",\"bing\",\"BMW.DE\",\"Mobile.DE\"),\n target = c(\"Tagesschau.de\", \"BMW.DE\",\"DirectExit\",\"DirectExit2\",\"Google.com\",\"BMW.DE\",\"BMWgroup.com\",\"BMWAuto\",\"directaccess\", \"BMW.DE\" ,\"Peugot\", \"Peugot(2)\",\"bing\",\"BMW.DE\",\"Mobile.DE\",\"Mobile_Last\"),\n value=c(\"8\",\"6.3\",\"5.5\",\"5.4\",\"5.4\",\"23.5\",\"11\",\"5.4\",\"3\",\"5\",\"4.5\",\"8\",\"6.3\",\"5.5\",\"5.4\",\"5.4\"))\n #return(data)\n })\n\n\n\n #output$table <- renderTable({\n # return(data())\n #})\n\n\n output$sankey <- renderChart2({ \n sankeyPlot <- rCharts$new()\n sankeyPlot$setLib(\"C:/Users/neha.sharma/Desktop/rCharts_d3_sankey-gh-pages/libraries/widgets/d3_sankey\")\n #C:/Users/neha.sharma/Desktop/rCharts_d3_sankey-gh-pages/libraries/widgets/d3_sankey\n sankeyPlot$set(\n data = data(),\n\n nodeWidth = 15,\n nodePadding = 10,\n layout = 40,#32\n labelFormat = \".1%\",\n width = 800,\n height = 600\n )\n\n return(sankeyPlot)\n })\n})\n"} {"post_id":46094396,"creation_date":"2017-09-07 10:45:47","snippet":"library(shiny)\nlibrary(shinyjs)\n\nui <- fluidPage(\n useShinyjs(),\n htmlOutput(\"filecontainer\")\n)\n\nserver <- function(input, output, session){\n session$onFlushed(once = T, function(){\n runjs(\"\n console.log('I arrive here')\n $('#filecontainer').load(function(){\n console.log('But not here') \n var iframe = $('#filecontainer').contents();\n iframe.find('#a').click(function(){\n alert('I want to arrive here');\n });\n });\n \")\n }) \n\n output$filecontainer <- renderUI({\n tags$iframe(src = \"fileWithLink.html\", height = 600, width = 1200)\n })\n}\n\nshinyApp(ui, server)\n"} {"post_id":27990932,"creation_date":"2015-01-16 18:59:59","snippet":"Var1 <- c(rnorm(50, 1, 0.5), rnorm(50, -0.6, 0.2))\nVar2 <- c(rnorm(50, -0.8, 0.2), rnorm(50, 2, 1))\nx <- matrix(c(Var1, Var2), nrow = 100, ncol = 2)\ny <- c(rep(1, 50), rep(0, 50))\ndnn <- sae.dnn.train(x, y, hidden = c(5, 5))\n## predict by dnn\ntest_Var1 <- c(rnorm(50, 1, 0.5), rnorm(50, -0.6, 0.2))\ntest_Var2 <- c(rnorm(50, -0.8, 0.2), rnorm(50, 2, 1))\ntest_x <- matrix(c(test_Var1, test_Var2), nrow = 100, ncol = 2)\nnn.test(dnn, test_x, y)\n"} {"post_id":46096942,"creation_date":"2017-09-07 12:55:14","snippet":"library(dbplyr)\nlibrary(nycflights13)\n\n## Working chunk\ncon <-DBI::dbConnect(RSQLite::SQLite(), \":memory:\")\nDBI::dbWriteTable(con, \"flights\", flights)\nDBI::dbGetQuery(con, \"SELECT origin, flight \nFROM flights WHERE origin like '%jf%'\")\n## End working chunk\n\n## The below code does not work \nflights <- tbl(con,\"flights\")\nflights %>% \n select(origin, flight) %>% \n filter(grepl('jf', origin))\n"} {"post_id":27993208,"creation_date":"2015-01-16 21:24:42","snippet":"# Example code\n\n# category is a factor with levels A and B; amt is the variable to model/forecast\n# using data.table syntax to create a vector for each category\nvec1 <- dt[category == 'A']$amount\nvec2 <- dt[category == 'B']$amount\n\n# Create ts objects from above vectors\nts1 <- ts(vec1, start=c(start_year, start_month), end=c(end_year, end_month), frequency=12)\nts2 <- ts(vec2, start=c(start_year, start_month), end=c(end_year, end_month), frequency=12)\n\n# Fit model \nfit1 <- auto.arima(ts1, trace = TRUE, stepwise = FALSE)\nfit2 <- auto.arima(ts2, trace = TRUE, stepwise = FALSE)\n\n\n# Forecast out using selected models\nh <- 12\nfcast1 <- forecast(fit1, h)\nfcast2 <- forecast(fit2, h)\n\n# funggcast pulls out data from the forecast object into a df (needed for ggplot2)\n# output columns are date, observed, fitted, forecast, lo80, hi80, lo95, hi95\nfcastdf1 <- funggcast(ts1, fcast1)\nfcastdf2 <- funggcast(ts2, fcast2)\n\n# Add in category\nfcastdf1$category <- 'A'\nfcastdf2$category <- 'B'\n\n\n# Merge into one df\ndf <- merge(fcastdf1, fcastdf2, all=T)\n\n# Basic qplot from ggplot2 package, I am actually incorporating quite a bit more formatting but this is just to give an idea\nqplot(x=date, \n y=observed, \n data=df, \n color=category, \n group=category, geom=\"line\") +\ngeom_line(aes(y=forecast), col='blue')\n"} {"post_id":66171401,"creation_date":"2021-02-12 11:52:57","snippet":"require(httr)\n\nkey <- \"68z...39k\"\nsecret <- \"71A...48i\"\n\nresult <- POST(\"https://www.coinspot.com.au/api/ro/my/balances\",\n body = list('nonce'=as.integer(as.POSIXct(Sys.time()))), add_headers(\"key\"=key,\"sign\"=openssl::sha512(\"https://www.coinspot.com.au/api/ro/my/balances\",key = secret)))\n\ncontent(result)\n"} {"post_id":65782787,"creation_date":"2021-01-18 22:16:20","snippet":"library(dplyr)\nlibrary(ggplot2)\nlibrary(ggrepel)\nlibrary(scales)\nthreshold = 0.05 \nage <- data.frame(Age = c(\"20 - 29\", \"30 - 39\", \"40 - 49\", \"50 - 59\", \"60 - 69\"), count = c(27, 29, 26, 16, 2))\nage <- age %>% mutate(percent = count/sum(count),\n cs = rev(cumsum(rev(percent))),\n ypos = percent/2 + lead(cs, 1),\n ypos = ifelse(is.na(ypos), percent/2, ypos),\n xpos = ifelse(percent > threshold, 1.8, 1.3),\n xn = ifelse(percent > threshold, 0, 0.5))\nggplot(age, aes_string(x = 1, y = \"percent\", fill = \"Age\")) +\n geom_bar(width = 1 , stat = \"identity\", colour = \"black\") +\n geom_text_repel(aes(label = percent(percent, accuracy = 0.1), x = xpos, y = ypos), size = 7.5, nudge_x = age$xn, segment.size = .5, direction = \"x\", force = 0.5, hjust = 1) +\n coord_polar(\"y\" , start = 0, clip = \"off\") + \n theme_minimal() +\n theme(axis.text.x = element_blank(),\n axis.title.x = element_blank(),\n axis.text.y = element_blank(),\n axis.title.y = element_blank(),\n panel.border = element_blank(),\n panel.grid = element_blank(),\n legend.title = element_text(size = 22.5),\n legend.text = element_text(size = 19.5),\n legend.box.margin=margin(c(0,0,0,30))) +\n labs(fill = \"Age\") +\n scale_fill_manual(values = c(\"#2B83BA\", \"#FDAE61\", \"#FFFF99\", \"#ABDDA4\", \"#D7191C\"))\n"} {"post_id":29713889,"creation_date":"2015-04-18 06:41:25","snippet":"set.seed(100)\npos <- sample(1:100000000, 10000000, replace=F)\ndf <- data.table(pos, name=\"arbitrary_string\")\nquery <- sample(1:100000000, 10000, replace=F)\ndf_list <- lapply(query, function(x) subset(df, pos >= x - 10000 & pos <= x + 10000))\noutput <- rbindlist(df_list)\n"} {"post_id":47524602,"creation_date":"2017-11-28 05:31:15","snippet":"#downloading tweets\ntweets <- searchTwitter(\"#hanshtag\",n = 5000, lang = \"en\",resultType = \"recent\")\n# removing re tweets \nno_retweets <- strip_retweets(tweets , strip_manual = TRUE)\n\n#converts to data frame\ndf <- do.call(\"rbind\", lapply(no_retweets , as.data.frame))\n\n#remove odd characters\ndf$text <- sapply(df$text,function(row) iconv(row, \"latin1\", \"ASCII\", sub=\"\")) #remove emoticon\ndf$text = gsub(\"(f|ht)tp(s?)://(.*)[.][a-z]+\", \"\", df$text) #remove URL\nsample <- df$text\n\n\n # Cleaning Tweets \n sum_txt1 <- gsub(\"(RT|via)((?:\\\\b\\\\w*@\\\\w+)+)\",\"\",sample)\n sum_txt2 <- gsub(\"http[^[:blank:]]+\",\"\",sum_txt1)\n sum_tx3 <- gsub(\"@\\\\w+\",\"\",sum_txt2)\n sum_tx4 <- gsub(\"[[:punct:]]\",\" \", sum_tx3)\n sum_tex5 <- gsub(\"[^[:alnum:]]\", \" \", sum_tx4)\n sum_tx6 <- gsub(\"RT \",\"\", sum_tex5)\n\n # WordCloud\n\n # data frame is not good for text convert it corpus\n corpus <- Corpus(VectorSource(sum_tx6))\n clean.tweets<- tm_map(corpus , content_transformer(tolower)) #converting everything to lower cases\n clean.tweets<- tm_map(guj_clean,removeWords, stopwords(\"english\")) #stopword are words like of, the, a, as..\n clean.tweets<- tm_map(guj_clean, removeNumbers)\n clean.tweets<- tm_map(guj_clean, stripWhitespace)\n"} {"post_id":47524918,"creation_date":"2017-11-28 06:01:18","snippet":"aDT <- data.table(col1 = c(1,1,2,2), col2 = c(\"A\",\"A\",\"B\",\"B\"), ExtractDate = c(\"2017-01-01\",\"2016-01-01\",\"2015-01-01\",\"2014-01-01\"))\nbDT <- data.table(col1 = c(1,1,1,2), col2 = c(\"A\",\"A\",\"A\",\"B\"), date_pol = c(\"2017-05-20\",\"2016-05-20\",\"2015-05-20\",\"2014-05-20\"), Value = c(1,2,3,4))\ncDT <- data.table(col1 = c(1,1,2,2), col2 = c(\"A\",\"A\",\"B\",\"B\"), ExtractDate = c(\"2017-01-01\",\"2016-01-01\",\"2015-01-01\",\"2014-01-01\")\n ,date_pol = c(\"2016-05-20\",\"2015-05-20\",\"2014-05-20\",NA), Value = c(2,3,4,NA))\n\n\naDT[,ExtractDate := ymd(ExtractDate)]\nbDT[,date_pol := ymd(date_pol)]\naDT[order(-ExtractDate)]\nbDT[order(-date_pol)]\n"} {"post_id":49083239,"creation_date":"2018-03-03 10:36:46","snippet":"library(reshape2)\n\ndata <- mtcars[, c(1,3,4,5,6,7)]\ncormat <- round(cor(data),2)\nmelted_cormat <- melt(cormat, na.rm = TRUE)\n\nggplot(\n data = melted_cormat,\n aes(Var1, Var2, fill=value)\n) +\n geom_tile() +\n geom_text(\n aes(Var2, Var1, label = value)\n ) +\n scale_fill_gradient2(\n low = 'red',\n high = 'blue',\n mid = 'white', \n midpoint = 0, # <-- look at this\n limit = c(-1, 1)\n ) \n"} {"post_id":68100298,"creation_date":"2021-06-23 12:57:36","snippet":"library(dplyr)\nlibrary(plotly)\n\nset.seed(77)\n\nsample_data = data.frame(x = c(1:100), y = rnorm(100, mean = 1, sd = 0.5)) %>% \n mutate(z = x*y,\n attr = if_else(x>50,\"Big\",\"Small\"))\n\nplot_ly() %>%\n add_trace(x = sample_data$x, \n y = sample_data$y, \n z = sample_data$z,\n color = sample_data$attr,\n colors = c(\"cyan4\",\"orange\"),\n type = \"scatter3d\",\n mode = \"markers\",\n opacity = 0.5,\n size = 1) %>%\n layout(legend = list(x = 0.5, \n y = 0.9,\n bgcolor = \"rgba(0,0,0,0)\"))\n"} {"post_id":32123288,"creation_date":"2015-08-20 16:13:26","snippet":"plot.build = ggplot_build(plot)\n\nxpos = numeric(4)\nxpos[2] = xpos[3] = plot.build$panel$ranges[[1]]$x.range[1]\nxpos[1] = xpos[4] = plot.build$panel$ranges[[1]]$x.range[2]\n\nypos = numeric(4)\nypos[1] = ypos[2] = plot.build$panel$ranges[[1]]$y.range[2]\nypos[3] = ypos[4] = plot.build$panel$ranges[[1]]$y.range[1]\n\n\nplot = plot + geom_text(aes(x2,y2,label = texthere), \n data.frame(x2=xpos, y2=ypos, texthere=c(\"1\", \"2\", \"3\", \"4\")),\n color=\"#4daf4a\", size=4)\n"} {"post_id":68107467,"creation_date":"2021-06-23 22:00:49","snippet":"x <- 1:10 # some linear vector\ny <- rev(cumsum(c(tail(x,1),diff(x))))\n\nplot(rep(NA,20),t=\"l\" , ylim = c(1,20))\nlines(x,col=2,lwd=5)\nlines(y,col=4,lty=5)\n"} {"post_id":68107467,"creation_date":"2021-06-23 22:00:49","snippet":"set.seed(123)\nx <- cumsum(rnorm(10)) # real vector\ny <- rev(cumsum(c(tail(x,1),diff(x))))\n\nplot(rep(NA,20),t=\"l\" , ylim = c(-5,10))\nlines(x,col=2,lwd=5)\nlines(y,col=4,lty=5)\n"} {"post_id":49088627,"creation_date":"2018-03-03 19:59:49","snippet":"# replacing the graphic window parameter so the color bars would fit\npar( oma = c(0,1,1,1), mgp = c(1,0.5,0), mar = c(10,2,2,2) )\n\n# load necessary packages\nlibrary( squash )\nlibrary( dendextend )\n\n# \"initializatin\"\ndata(\"mtcars\")\nmyDend <- as.dendrogram(hclust(dist(mtcars))) \n\n# creating the numeric & color matrix used for\n# (attempted) labels & colors bars, respectively\nmyStatus <- cbind(mtcars$vs,mtcars$am)\nmyColors <- matrix(c(\"mintcream\",\"firebrick3\")[1 + myStatus],ncol = 2)\nmyColors <- matrix(c(\"mintcream\",\"firebrick3\")[1 + cbind(mtcars$vs,mtcars$am)],\n ncol = 2)\n\n\n# default function without trying to force the label to a particular design\nplot(myDend)\ncmap <- squash::makecmap( myStatus, n = 2,colFn = colorRampPalette(c(\"mintcream\",\"firebrick3\")))\nvkey(cmap, \"Status\")\ncolored_bars(colors = myColors, dend = myDend, rowLabels = c(\"VS\",\"AM\"))\n\n# >> attempt 1 << trying to force breaks to 0 and 1\nplot(myDend)\ncmap <- squash::makecmap( myStatus, n = 2,colFn = colorRampPalette(c(\"mintcream\",\"firebrick3\")), breaks = c(0,1))\nvkey(cmap, \"Status\")\ncolored_bars(colors = myColors, dend = myDend, rowLabels = c(\"VS\",\"AM\"))\n\n# >> attempt 2 << trying to force breaks to 0 and 1\nplot(myDend)\ncmap <- squash::makecmap( myStatus, n = 2,colFn = colorRampPalette(c(\"mintcream\",\"firebrick3\")))\nvkey(cmap, \"Status\", skip = c(0.5))\ncolored_bars(colors = myColors, dend = myDend, rowLabels = c(\"VS\",\"AM\"))\n"} {"post_id":14573036,"creation_date":"2013-01-28 23:15:54","snippet":"#this is needed to run custHeat\nzeroInterval <- function(mat, colors){\n #modified version of findInterval such that zero is given its own category\n #This function takes intervals as left exclusive, right inclusive.\n #This is mostly so that intervals consisting of a single value will still be represented.\n intervalMat <- matrix(0, nrow=nrow(mat), ncol=ncol(mat))\n j <- 1\n for(i in 1:(length(colors) - 1)){\n if(colors[i] != colors[i+1]){\n intervalMat[mat>colors[i] & mat<=colors[i+1]] <- j\n j <- j + 1\n } else {\n intervalMat[mat==colors[i]] <- j\n j <- j + 1\n }\n }\n return(intervalMat)\n}\n\n#this actually plots the heatmap\ncustHeat <- function(M){\n\n #create color bins/ranges for skewed matrix\n color_bins <- c(-5, -4, -3, -2, -1, 0, 0, 1)\n colors <- c('#67001F', '#B2182B', '#D6604D', '#F4A582', '#FDDBC7', \"#FFFFFF\", '#C6DBEF')\n\n #create complete color palette\n color_palette <- colorRampPalette(colors)(length(color_bins) - 1)\n\n #This function assigns a number to each matrix value, so that it is colored correctly\n mod_mat <- zeroInterval(random_matrix, color_bins)\n\n\n ## remove background and axis from plot\n theme_change <- theme(\n plot.background = element_blank(),\n panel.grid.minor = element_blank(),\n panel.grid.major = element_blank(),\n panel.background = element_blank(),\n panel.border = element_blank(),\n axis.line = element_blank(),\n axis.ticks = element_blank(),\n axis.text.x = element_blank(),\n axis.text.y = element_blank(),\n axis.title.x = element_blank(),\n axis.title.y = element_blank()\n )\n\n ## output the graphics\n ggplot(melt(mod_mat), aes(x = X1, y = X2, fill = factor(value))) +\n geom_tile(color = \"black\") +\n scale_fill_manual(values = color_palette, name = \"\") +\n theme_change\n}\n\n##create random matrix, skewed toward negative values\nrandom_matrix <- matrix(runif(100, min = -5, max = 1), nrow = 10)\nrandom_matrix[1,] <- 0 #zeros should be at the top row of the heatmap\ncustHeat(random_matrix)\n"} {"post_id":14574223,"creation_date":"2013-01-29 01:28:59","snippet":"library(rgl)\n\ny = seq(-5,25,by=0.1)\nx = seq(5,20,by=0.2)\n\nNAs <- rep(NA, length(x)*length(y))\nz <- matrix(NAs, length(x), byrow = T)\nfor(i in seq(1,length(x))) {\n for(j in seq(1,length(y))) {\n val = x[i] * y[j]\n z[i,j] = val\n if(z[i,j] < 0.02) {\n z[i,j] = NA\n }\n\n }\n}\n\ncol <- rainbow(length(x))[rank(x)]\n\nopen3d()\npersp3d(x,y,z,color=col,xlim=c(5,20),ylim=c(5,10),axes=T,box=F,xlab=\"X Axis\",ylab=\"Y Axis\",zlab=\"Z Axis\")\n"} {"post_id":49668048,"creation_date":"2018-04-05 08:51:25","snippet":"library(shiny)\n\njsCode <- tags$head(tags$script(HTML( \"\n$(document).on('shiny:value', function(e){\n if (e.target.id === 'my_iframe')\n {\n alert('JS code is running now.');\n console.log(e);\n var iframe = document.getElementById('my_iframe');\n console.log(iframe.width);\n }\n})\")))\n\nui <- fluidPage(\n jsCode,\n uiOutput('my_iframe')\n)\n\nserver <- function(input, output){\n output$my_iframe <- renderUI({\n tags$iframe(src='http://www.example.com/', height=600)\n })\n}\n\nshinyApp(ui = ui, server = server)\n"} {"post_id":49668265,"creation_date":"2018-04-05 09:02:33","snippet":"d <- data.frame(x = mtcars$mpg, y = 0.10)\nvlines <- rbind(aggregate(d[1], d[2], mean), \n aggregate(d[1], d[2], median))\nvlines$stat <- rep(c(\"mean\", \"median\"), each = nrow(vlines)/2)\nlibrary(\"ggplot2\")\nggplot(data = d, aes(x = x, y = ..density..)) + \n geom_histogram(fill = \"lightblue\", color = \"black\") + \n geom_vline(data = vlines, mapping = aes(xintercept = x, colour = stat), \n show.legend = TRUE) +\n theme(legend.direction = \"vertical\", \n legend.position = \"right\",\n # legend.key = element_rect(size = 2),\n legend.key.size = unit(3, \"cm\"),\n # legend.key.width = unit(2, \"cm\"),\n # legend.key.height = unit(1, \"cm\")\n )\n"} {"post_id":49668339,"creation_date":"2018-04-05 09:05:48","snippet":"#Preparing multiple dependancies----\npackages <- c(\"readxl\",\"dplyr\",\"leaflet\",\"htmltools\", \"sp\", \"osrm\")\ninstall.packages(packages)\nlapply(packages, library,character.only=TRUE)\n\n###\n\n#Loading in Locations----\nLocation <- read_excel(\"filepath.xlsx\", sheet=1)\n\n###\n\n#Extract Lon and Lat and create spatial dataframe\nxy <- Location[, c(3,4)]\n\nspatialdf <- SpatialPointsDataFrame(coords = xy, data = Location, proj4string = CRS(\"+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0\"))\nclass(spatialdf)\n\n#Create Isochrone points\niso1 <- osrmIsochrone(loc = c(-2.3827439,53.425705), breaks = seq(from = 0, to = 60, by = 5))\niso2 <- osrmIsochrone(loc = c(-0.85074928,51.325871), breaks = seq(from = 0, to = 60, by = 5)) \niso3 <- osrmIsochrone(loc = c(-2.939367,51.570344), breaks = seq(from = 0, to = 60, by = 5)) \niso4 <- osrmIsochrone(loc = c(-3.9868026,55.823102), breaks = seq(from = 0, to = 60, by = 5)) \niso5 <- osrmIsochrone(loc = c(-0.92104073,53.709006), breaks = seq(from = 0, to = 60, by = 5))\n\n\n#Create Drive Time Interval descriptions\niso1@data$drive_times <- factor(paste(iso1@data$min, \"to\", iso1@data$max, \"mins\"))\niso2@data$drive_times <- factor(paste(iso2@data$min, \"to\", iso2@data$max, \"mins\"))\niso3@data$drive_times <- factor(paste(iso3@data$min, \"to\", iso3@data$max, \"mins\"))\niso4@data$drive_times <- factor(paste(iso4@data$min, \"to\", iso4@data$max, \"mins\"))\niso5@data$drive_times <- factor(paste(iso5@data$min, \"to\", iso5@data$max, \"mins\"))\n\n#Create Colour Palette for each time interval\nfactPal1 <- colorFactor(rev(heat.colors(12)), iso1@data$drive_times)\nfactPal2 <- colorFactor(rev(heat.colors(12)), iso2@data$drive_times)\nfactPal3 <- colorFactor(rev(heat.colors(12)), iso3@data$drive_times)\nfactPal4 <- colorFactor(rev(heat.colors(12)), iso4@data$drive_times)\nfactPal5 <- colorFactor(rev(heat.colors(12)), iso5@data$drive_times)\n\n#Draw Map\nleaflet()%>%\n addProviderTiles(\"CartoDB.Positron\", group=\"Greyscale\")%>%\n addMarkers(data=spatialdf,lng=spatialdf$Longitude, lat=spatialdf$Latitude, popup = htmlEscape(~`Locate`))%>%\n addPolygons(fill = TRUE, stroke = TRUE, color = \"black\",fillColor = ~factPal1(iso1@data$drive_times), weight = 0.5, fillOpacity = 0.2, data=iso1, popup = iso1@data$drive_times, group = \"Drive Time\")%>%\n addPolygons(fill = TRUE, stroke = TRUE, color = \"black\",fillColor = ~factPal2(iso2@data$drive_times), weight = 0.5, fillOpacity = 0.2, data=iso2, popup = iso2@data$drive_times, group = \"Drive Time\")%>%\n addPolygons(fill = TRUE, stroke = TRUE, color = \"black\",fillColor = ~factPal3(iso3@data$drive_times), weight = 0.5, fillOpacity = 0.2, data=iso3, popup = iso3@data$drive_times, group = \"Drive Time\")%>%\n addPolygons(fill = TRUE, stroke = TRUE, color = \"black\",fillColor = ~factPal4(iso4@data$drive_times), weight = 0.5, fillOpacity = 0.2, data=iso4, popup = iso4@data$drive_times, group = \"Drive Time\")%>%\n addPolygons(fill = TRUE, stroke = TRUE, color = \"black\",fillColor = ~factPal5(iso5@data$drive_times), weight = 0.5, fillOpacity = 0.2, data=iso5, popup = iso5@data$drive_times, group = \"Drive Time\")%>%\n addLegend(\"bottomright\", pal = factPal1, values = iso1@data$drive_times, title = \"Drive Time\") \n"} {"post_id":32125795,"creation_date":"2015-08-20 18:34:03","snippet":"library(data.table)\nlibrary(dplyr)\n\nset.seed(1)\nN <- 16 # in application N is very large\nk <- 6 # in application k << N\ndt <- data.table(id = sample(letters[1:k], N, replace=T), value=runif(N)) %>%\n arrange(id)\nt(dt$id)\n\n# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16]\n# [1,] \"a\" \"b\" \"b\" \"b\" \"b\" \"c\" \"c\" \"c\" \"d\" \"d\" \"d\" \"e\" \"e\" \"f\" \"f\" \"f\" \n"} {"post_id":17713275,"creation_date":"2013-07-18 02:02:40","snippet":" library(party)\n\n ctree_preds <- function(tr,vnames){ \n res <- character(0)\n traverse <- function(treenode,vnames,res){\n if(treenode$terminal){\n return(res)\n } else {\n res <- c(res,vnames[treenode$psplit$variableID])\n traverse(treenode$left , vnames, res )\n traverse(treenode$right, vnames, res )\n }\n }\n traverse(tr,vnames,res)\n return(unique(res))\n }\n\n airq <- subset(airquality, !is.na(Ozone))\n airct <- ctree(Ozone ~ ., data = airq,\n controls = ctree_control(maxsurrogate = 3))\n plot(airct)\n\n ctree_preds(airct@tree,names(airq)[-1])\n"} {"post_id":35680223,"creation_date":"2016-02-28 08:11:44","snippet":"range <- seq(as.POSIXct(\"2015/4/18 06:00\"),as.POSIXct(\"2015/4/18 22:00\"),\"mins\")\n\ndf <- data.frame(matrix(nrow=length(range),ncol=4))\ndf[,1] <- c(1:length(range))\ndf[,2] <- 2*c(1:length(range))\ndf[,3] <- 3*c(1:length(range))\ndf[,4] <- range\n"} {"post_id":50920160,"creation_date":"2018-06-19 03:19:51","snippet":"library(data.table)\n\ndates = structure(list(date = structure(c(17562, 17590, 17621, 17651, \n 17682, 17712, 17743, 17774, 17804, 17835, 17865, 17896), class = \"Date\")), \n row.names = c(NA, -12L), class = \"data.frame\")\n\n\ndat = structure(list(date = structure(c(17546, 17743, 17778, 17901, \n 17536, 17806, 17901, 17981, 17532, 17722, 17969, 18234), class = \"Date\"), \n country = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, \n 3L, 3L, 3L), .Label = c(\"AAA\", \"BBB\", \"CCC\"), class = \"factor\"), \n state = structure(c(1L, 1L, 2L, 3L, 4L, 1L, 2L, 5L, 6L, 1L, \n 2L, 2L), .Label = c(\"S1\", \"S2\", \"S3\", \"S4\", \"S5\", \"S6\"), class = \"factor\"), \n item = structure(c(1L, 2L, 4L, 6L, 3L, 5L, 3L, 2L, 2L, 4L, \n 5L, 7L), .Label = c(\"M1\", \"M2\", \"M3\", \"M4\", \"M5\", \"M6\", \"M7\"\n ), class = \"factor\"), value = c(67L, 10L, 50L, 52L, 93L, \n 50L, 62L, 46L, 6L, 30L, 30L, 14L)), row.names = c(NA, -12L\n ), class = \"data.frame\")\n\n\ndates = data.table(dates)\ndat = data.table(dat)\n\n\nsetkey(dates, date)\nsetkey(dat, date)\n"} {"post_id":32575904,"creation_date":"2015-09-15 00:38:03","snippet":"#function to create seasons\nd = function(month_day) which(lut$month_day == month_day)\nlut = data.frame(all_dates = as.POSIXct(\"2012-1-1\") + ((0:365) * 3600 * 24),\n season = NA)\nlut = within(lut, { month_day = strftime(all_dates, \"%b-%d\") })\nlut[c(d(\"Jan-01\"):d(\"Mar-15\"), d(\"Nov-08\"):d(\"Dec-31\")), \"season\"] = \"winter\"\nlut[c(d(\"Mar-16\"):d(\"Apr-30\")), \"season\"] = \"spring\"\nlut[c(d(\"May-01\"):d(\"Sep-27\")), \"season\"] = \"summer\"\nlut[c(d(\"Sep-28\"):d(\"Nov-07\")), \"season\"] = \"autumn\"\nrownames(lut) = lut$month_day\n\n## create date data frame and assign seasons\ndates = data.frame(dates =seq(as.Date('2010-01-01'),as.Date('2012-12-31'),by = 1))\n\n dates = within(dates, { \n season = lut[strftime(dates, \"%b-%d\"), \"season\"] \n})\n"} {"post_id":17710469,"creation_date":"2013-07-17 21:21:42","snippet":"cattest <- file(\"cattest.txt\")\ncat(\"First thing\", file = cattest)\ncat(\"Second thing\", file = cattest, append = TRUE)\nclose(cattest)\n\nsink(\"cattest_sink.txt\")\ncat(\"First thing\")\ncat(\"Second thing\")\nsink()\n"} {"post_id":34167607,"creation_date":"2015-12-08 22:51:55","snippet":"# Original\nA1 <- c(1,2,3,3,3,4,4,5,6,7)\nB1 <- c(11,13,15,17,17,18,18,19,20,22)\n#change order 1\nA2 <- c(7,6,5,4,4,3,3,3,2,1) \nB2 <- c(22,20,19,18,18,17,17,15,13,11)\n#change order 2\nA3 <- c(3,3,3,4,4,5,6,7,1,2) \nB3 <- c(17,17,18,18,19,13,20,11,22,15)\nsum1 <- A1+B1; sum1\nsum2 <- A1+B2; sum2\nsum3 <- A3+B3; sum3\n"} {"post_id":50916523,"creation_date":"2018-06-18 19:48:05","snippet":"library(RJDBC)\nlibrary(DBI)\nlibrary(pool)\nlibrary(dplyr)\nlibrary(dbplyr)\n\ndrv <- RJDBC::JDBC('com.amazonaws.athena.jdbc.AthenaDriver', '/opt/jdbc/AthenaJDBC41-1.1.0.jar')\n\npool_instance <- dbPool(\n drv = drv,\n url = \"jdbc:awsathena://athena.us-west-2.amazonaws.com:443/\",\n user = \"me\",\n s3_staging_dir = \"s3://somedir\",\n password = \"pwd\"\n)\n\nmydata <- DBI::dbGetQuery(pool_instance, \"SELECT * \n FROM myDB.myTable\n LIMIT 10\")\n\nmydata\n"} {"post_id":37613345,"creation_date":"2016-06-03 11:35:21","snippet":"res.upper <- rnorm(4950)\nres <- matrix(0, 100, 100)\nres[upper.tri(res)] <- res.upper\nrm(res.upper)\ndiag(res) <- 1\nres[lower.tri(res)] <- t(res)[lower.tri(res)]\n"} {"post_id":72534388,"creation_date":"2022-06-07 16:03:57","snippet":"class(Seatbelts)\n#> [1] \"mts\" \"ts\"\nSeatbelts\n#> DriversKilled drivers front rear kms PetrolPrice VanKilled law\n#> Jan 1969 107 1687 867 269 9059 0.10297181 12 0\n#> Feb 1969 97 1508 825 265 7685 0.10236300 6 0\n#> Mar 1969 102 1507 806 319 9963 0.10206249 12 0\n...\nSeatbelts[,0]\n#> \n#> Jan 1969\n#> Feb 1969\n#> Mar 1969\n...\nrownames(Seatbelts)\n#> NULL\nrow.names(Seatbelts)\n#> NULL\nrow.names(as.matrix(Seatbelts))\n#> NULL\n"} {"post_id":53347495,"creation_date":"2018-11-17 01:51:43","snippet":"library(shiny)\nlibrary(googleway)\n\nkey <- \"MyKey\"\nset_key(key = key)\ngoogle_keys()\n\nui <- shiny::basicPage(\n\n div(\n textInput(inputId = \"my_address\", label = \"\") \n ,textOutput(outputId = \"copy_of_address\")\n ,HTML(paste0(\"\n