├── .Rprofile ├── .Rbuildignore ├── .gitignore ├── renv ├── .gitignore ├── settings.dcf └── activate.R ├── NAMESPACE ├── tests ├── testthat.R └── testthat │ ├── test_random_forest.R │ ├── test-linreg.R │ └── test-dt_party.R ├── shinify.Rproj ├── jumpstart ├── decision_tree_party.R ├── linear_regression.R ├── random_forest.R ├── support_vector_machine.R ├── decision_tree_rpart.R └── logistic_regression.R ├── DESCRIPTION ├── LICENSE ├── .github └── workflows │ ├── new-r.yml │ ├── test-coverage.yml │ └── r.yml ├── man └── shinify.Rd ├── README.md ├── renv.lock └── R └── main.R /.Rprofile: -------------------------------------------------------------------------------- 1 | source("renv/activate.R") 2 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^renv$ 2 | ^renv\.lock$ 3 | ^.*\.Rproj$ 4 | ^\.Rproj\.user$ 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | .DS_Store 6 | /tests/local-testscript.R 7 | -------------------------------------------------------------------------------- /renv/.gitignore: -------------------------------------------------------------------------------- 1 | library/ 2 | local/ 3 | cellar/ 4 | lock/ 5 | python/ 6 | sandbox/ 7 | staging/ 8 | .Rproj.user/ 9 | .Rhistory 10 | .RData 11 | .Ruserdata 12 | .DS_Store 13 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(shinify) 4 | importFrom(stats,predict) 5 | importFrom(utils,install.packages) 6 | importFrom(utils,read.csv) 7 | importFrom(utils,write.csv) 8 | -------------------------------------------------------------------------------- /renv/settings.dcf: -------------------------------------------------------------------------------- 1 | bioconductor.version: 2 | external.libraries: 3 | ignored.packages: 4 | package.dependency.fields: Imports, Depends, LinkingTo 5 | r.version: 6 | snapshot.type: implicit 7 | use.cache: TRUE 8 | vcs.ignore.cellar: TRUE 9 | vcs.ignore.library: TRUE 10 | vcs.ignore.local: TRUE 11 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # This file is part of the standard setup for testthat. 2 | # It is recommended that you do not modify it. 3 | # 4 | # Where should you do additional test configuration? 5 | # Learn more about the roles of various files in: 6 | # * https://r-pkgs.org/tests.html 7 | # * https://testthat.r-lib.org/reference/test_package.html#special-files 8 | 9 | library(testthat) 10 | library(shinify) 11 | 12 | test_check("shinify") 13 | -------------------------------------------------------------------------------- /shinify.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --no-manual --no-examples 22 | -------------------------------------------------------------------------------- /tests/testthat/test_random_forest.R: -------------------------------------------------------------------------------- 1 | test_that("Test random forest", { 2 | install.packages("randomForest", repos = "http://cran.us.r-project.org") 3 | library(randomForest) 4 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 5 | 6 | # create variables 7 | legendary <- data$is_legendary 8 | attack <- data$attack 9 | defense <- data$defense 10 | 11 | # split train and test data 12 | data <- data.frame(legendary, attack, defense) 13 | data_train <- data[1:(nrow(data) - 100), ] 14 | 15 | # actual random forest 16 | rf_mod <- randomForest(legendary ~ attack + defense, data = data_train) 17 | expect_no_error(shinify(rf_mod, modeltype = "rf")) 18 | expect_error(shinify(rf_mod, modeltype = "rf", variables = c("Eins", "Zwei"))) 19 | }) 20 | -------------------------------------------------------------------------------- /jumpstart/decision_tree_party.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | library(party) 3 | 4 | # load data 5 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 6 | 7 | # create variables 8 | legendary <- data$is_legendary 9 | attack <- data$attack 10 | defense <- data$defense 11 | 12 | # split train and test data 13 | data <- data.frame(legendary, attack, defense) 14 | data_train <- data[1:(nrow(data) - 100), ] 15 | data_test <- data[(nrow(data) - 99):nrow(data), ] 16 | 17 | # actual decision tree 18 | dt <- ctree(legendary ~ attack + defense, data = data_train) 19 | summary(dt) 20 | 21 | # actual prediction that pokemon is legendary 22 | predict(dt, data_test, type = "response") 23 | 24 | # shinify decision tree 25 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric")) 26 | -------------------------------------------------------------------------------- /jumpstart/linear_regression.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | 3 | # load data 4 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 5 | 6 | # create variables 7 | legendary <- data$is_legendary 8 | attack <- data$attack 9 | defense <- data$defense 10 | 11 | # split train and test data 12 | data <- data.frame(legendary, attack, defense) 13 | data_train <- data[1:(nrow(data) - 100), ] 14 | data_test <- data[(nrow(data) - 99):nrow(data), ] 15 | 16 | # actual linear regression 17 | lin_reg <- lm(legendary ~ attack + defense, data = data_train) 18 | summary(lin_reg) 19 | 20 | # input for new prediction 21 | attack <- 120 22 | defense <- 290 23 | test_data_new <- data.frame(attack, defense) 24 | 25 | # actual prediction that pokemon is legendary 26 | predict(lin_reg, test_data_new) 27 | 28 | # shinify linear regression 29 | shinify(lin_reg, modeltype = "lin_reg") 30 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: shinify 2 | Type: Package 3 | Title: Creates a shiny server to interact with your machine learning model. 4 | Version: 0.1.0 5 | Author: Christopher Ernst & Jonas Mielck | stackOcean GmbH 6 | Maintainer: The package maintainer 7 | Description: This package automaticly creates a shiny server to interact with your machine learning models. 8 | As the project is in the early development phase we currently support some selected models. 9 | Take a look in the jumpstart folder for currently supported models and libraries. 10 | The package creates a basic GUI with fields for input and output value depending on your model terms. 11 | No furhter coding is needed - simply enjoy and share your model. 12 | License: MIT License 13 | Encoding: UTF-8 14 | LazyData: true 15 | RoxygenNote: 7.2.1 16 | Suggests: 17 | testthat (>= 3.0.0) 18 | Config/testthat/edition: 3 19 | -------------------------------------------------------------------------------- /jumpstart/random_forest.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | library(randomForest) 3 | 4 | # load data 5 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 6 | 7 | # create variables 8 | legendary <- data$is_legendary 9 | attack <- data$attack 10 | defense <- data$defense 11 | 12 | # split train and test data 13 | data <- data.frame(legendary, attack, defense) 14 | data_train <- data[1:(nrow(data) - 100), ] 15 | data_test <- data[(nrow(data) - 99):nrow(data), ] 16 | 17 | # actual random forest 18 | rf_mod <- randomForest(legendary ~ attack + defense, data = data_train) 19 | summary(rf_mod) 20 | 21 | # input for new prediction 22 | attack <- 120 23 | defense <- 290 24 | test_data_new <- data.frame(attack, defense) 25 | 26 | # actual prediction that pokemon is legendary 27 | predict(rf_mod, newdata = data_test) 28 | 29 | # shinify random forest model 30 | shinify(rf_mod, modeltype = "rf") 31 | -------------------------------------------------------------------------------- /jumpstart/support_vector_machine.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | library(e1071) 3 | 4 | # load data 5 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 6 | 7 | # create variables 8 | legendary <- data$is_legendary 9 | attack <- data$attack 10 | defense <- data$defense 11 | 12 | # split train and test data 13 | data <- data.frame(legendary, attack, defense) 14 | data_train <- data[1:(nrow(data) - 100), ] 15 | data_test <- data[(nrow(data) - 99):nrow(data), ] 16 | 17 | # actual svm 18 | svm_mod <- svm(legendary ~ attack + defense, data = data_train) 19 | summary(svm_mod) 20 | 21 | # input for new prediction 22 | attack <- 120 23 | defense <- 290 24 | test_data_new <- data.frame(attack, defense) 25 | 26 | # actual predicted percentage that pokemon is legendary with decision tree 27 | predict(svm_mod, test_data_new) 28 | 29 | # shinify logistic model 30 | shinify(svm_mod, modeltype = "svm") 31 | -------------------------------------------------------------------------------- /jumpstart/decision_tree_rpart.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | library(rpart) 3 | 4 | # load data 5 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 6 | 7 | # create variables 8 | legendary <- data$is_legendary 9 | attack <- data$attack 10 | defense <- data$defense 11 | 12 | # split train and test data 13 | data <- data.frame(legendary, attack, defense) 14 | data_train <- data[1:(nrow(data) - 100), ] 15 | data_test <- data[(nrow(data) - 99):nrow(data), ] 16 | 17 | # grow tree 18 | dt <- rpart(legendary ~ attack + defense, data = data_train, method = "class") 19 | summary(dt) 20 | 21 | # input for new prediction 22 | attack <- 120 23 | defense <- 290 24 | test_data_new <- data.frame(attack, defense) 25 | 26 | # actual predicted percentage that pokemon is legendary with decision tree 27 | predict(dt, test_data_new) 28 | 29 | # shinify logistic model 30 | shinify(dt, modeltype = "dt_rpart") 31 | 32 | -------------------------------------------------------------------------------- /jumpstart/logistic_regression.R: -------------------------------------------------------------------------------- 1 | library(shinify) 2 | 3 | # load data 4 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 5 | 6 | # create variables 7 | legendary <- data$is_legendary 8 | attack <- data$attack 9 | defense <- data$defense 10 | 11 | # split train and test data 12 | data <- data.frame(legendary, attack, defense) 13 | data_train <- data[1:(nrow(data) - 100), ] 14 | data_test <- data[(nrow(data) - 99):nrow(data), ] 15 | 16 | # actual logistic regression 17 | log_reg <- glm(legendary ~ attack + defense, data = data_train, family = binomial()) 18 | summary(log_reg) 19 | 20 | # input for new prediction 21 | attack <- 120 22 | defense <- 290 23 | test_data_new <- data.frame(attack, defense) 24 | 25 | # definition of a sigmoid function to normalize predictions 26 | sigmoid <- function(x) { 27 | result <- exp(x) / (1 + exp(x)) 28 | return(result) 29 | } 30 | 31 | # actual predicted percentage that pokemon is legendary with glm model 32 | sigmoid(predict(log_reg, test_data_new)) 33 | 34 | # shinify logistic model 35 | shinify(log_reg, modeltype = "log_reg") 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 stackOcean 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /.github/workflows/new-r.yml: -------------------------------------------------------------------------------- 1 | # This workflow uses actions that are not certified by GitHub. 2 | # They are provided by a third-party and are governed by 3 | # separate terms of service, privacy policy, and support 4 | # documentation. 5 | # 6 | # See https://github.com/r-lib/actions/tree/master/examples#readme for 7 | # additional example workflows available for the R community. 8 | 9 | name: test for errors 10 | 11 | on: 12 | push: 13 | branches: ["main"] 14 | pull_request: 15 | branches: ["main"] 16 | 17 | permissions: 18 | contents: read 19 | 20 | jobs: 21 | build: 22 | runs-on: macos-latest 23 | strategy: 24 | matrix: 25 | r-version: ["release"] 26 | 27 | steps: 28 | - uses: actions/checkout@v3 29 | - name: Set up R ${{ matrix.r-version }} 30 | uses: r-lib/actions/setup-r@f57f1301a053485946083d7a45022b278929a78a 31 | with: 32 | r-version: ${{ matrix.r-version }} 33 | - name: Install dependencies 34 | run: | 35 | install.packages(c("remotes", "rcmdcheck")) 36 | remotes::install_deps(dependencies = TRUE) 37 | shell: Rscript {0} 38 | - name: Check 39 | run: rcmdcheck::rcmdcheck (args = c("--no-examples", "--no-manual"), error_on = "error") 40 | shell: Rscript {0} 41 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yml: -------------------------------------------------------------------------------- 1 | # This workflow uses actions that are not certified by GitHub. 2 | # They are provided by a third-party and are governed by 3 | # separate terms of service, privacy policy, and support 4 | # documentation. 5 | # 6 | # See https://github.com/r-lib/actions/tree/master/examples#readme for 7 | # additional example workflows available for the R community. 8 | 9 | name: test coverage ubuntu 10 | 11 | on: 12 | push: 13 | branches: ["main"] 14 | pull_request: 15 | branches: ["main"] 16 | 17 | permissions: 18 | contents: read 19 | 20 | jobs: 21 | build: 22 | runs-on: macos-latest 23 | strategy: 24 | matrix: 25 | r-version: ["release"] 26 | 27 | steps: 28 | - uses: actions/checkout@v3 29 | - name: Set up R ${{ matrix.r-version }} 30 | uses: r-lib/actions/setup-r@f57f1301a053485946083d7a45022b278929a78a 31 | with: 32 | r-version: ${{ matrix.r-version }} 33 | - name: Install dependencies 34 | run: | 35 | install.packages(c("remotes", "rcmdcheck")) 36 | remotes::install_deps(dependencies = TRUE) 37 | shell: Rscript {0} 38 | - name: Check 39 | run: rcmdcheck::rcmdcheck (args = c("--no-examples", "--no-manual"), error_on = "error") 40 | shell: Rscript {0} 41 | -------------------------------------------------------------------------------- /tests/testthat/test-linreg.R: -------------------------------------------------------------------------------- 1 | test_that("Test linear regression", { 2 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 3 | 4 | # create variables 5 | legendary <- data$is_legendary 6 | attack <- data$attack 7 | defense <- data$defense 8 | 9 | # split train and test data 10 | data <- data.frame(legendary, attack, defense) 11 | data_train <- data[1:(nrow(data) - 100), ] 12 | # actual linear regression 13 | lin_reg <- lm(legendary ~ attack + defense, data = data_train) 14 | expect_warning(shinify(lin_reg)) 15 | expect_error(shinify(model, modeltype = "lin_reg")) 16 | expect_error(shinify(model, modeltype = "lin_reg", variables = c("attack", "defense"))) 17 | expect_error(shinify(model, modeltype = "lin_reg", variables = c("attack", "defense"), variable_types = c("num", "turnschuh"))) 18 | expect_no_error(shinify(lin_reg, modeltype = "lin_reg")) 19 | expect_no_error(shinify(lin_reg, modeltype = "lin_reg", input_labels = c("1", "2"))) 20 | expect_no_error(shinify(lin_reg, modeltype = "lin_reg", app_title = "Hello")) 21 | expect_no_error(shinify(lin_reg, modeltype = "lin_reg", app_title = "Hello", app_theme = "superhero")) 22 | expect_no_error(shinify(lin_reg, modeltype = "lin_reg", app_title = "Hello", app_theme = "superhero", csv_upload = TRUE)) 23 | }) 24 | -------------------------------------------------------------------------------- /.github/workflows/r.yml: -------------------------------------------------------------------------------- 1 | # This workflow uses actions that are not certified by GitHub. 2 | # They are provided by a third-party and are governed by 3 | # separate terms of service, privacy policy, and support 4 | # documentation. 5 | # 6 | # See https://github.com/r-lib/actions/tree/master/examples#readme for 7 | # additional example workflows available for the R community. 8 | 9 | name: R 10 | 11 | on: 12 | pull_request: 13 | branches: ["dev"] 14 | 15 | permissions: 16 | contents: read 17 | 18 | jobs: 19 | build: 20 | runs-on: ubuntu-latest 21 | strategy: 22 | matrix: 23 | r-version: ["release"] 24 | steps: 25 | - uses: actions/checkout@v3 26 | - name: Set up R ${{ matrix.r-version }} 27 | uses: r-lib/actions/setup-r@f57f1301a053485946083d7a45022b278929a78a 28 | with: 29 | r-version: ${{ matrix.r-version }} 30 | repo-token: ${{ secrets.GITHUB_TOKEN }} 31 | - name: Install xmllint 32 | run: sudo apt-get install -y libcurl4-openssl-dev 33 | - name: Install dependencies 34 | run: | 35 | install.packages("devtools") 36 | devtools::install_github("stackOcean-official/shinify", host = "https://api.github.com") 37 | shell: Rscript {0} 38 | - name: Test linear 39 | run: | 40 | source("jumpstart/linear_regression.R") 41 | shell: Rscript {0} 42 | -------------------------------------------------------------------------------- /tests/testthat/test-dt_party.R: -------------------------------------------------------------------------------- 1 | test_that("test dt_party", { 2 | install.packages("party", repos = "http://cran.us.r-project.org") 3 | library(party) 4 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 5 | 6 | # create variables 7 | legendary <- data$is_legendary 8 | attack <- data$attack 9 | defense <- data$defense 10 | 11 | # split train and test data 12 | data <- data.frame(legendary, attack, defense) 13 | data_train <- data[1:(nrow(data) - 100), ] 14 | # actual linear regression 15 | dt <- ctree(legendary ~ attack + defense, data = data_train) 16 | expect_no_error( 17 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric"), app_title = "Hello", output_label = "3") 18 | ) 19 | expect_no_error( 20 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric"), app_theme = "lumen") 21 | ) 22 | expect_no_error( 23 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric"), csv_upload = TRUE) 24 | ) 25 | expect_no_error( 26 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric")) 27 | ) 28 | expect_error( 29 | shinify(dt, modeltype = "dt_party") 30 | ) 31 | expect_error( 32 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense")) 33 | ) 34 | expect_error( 35 | shinify(dt, modeltype = "dt_party", variable_types = c("numeric", "numeric")) 36 | ) 37 | expect_error( 38 | shinify(dt, modeltype = "dt_party", variables = c("attack", "defense"), variable_types = c("num", "turnschuh")) 39 | ) 40 | }) 41 | -------------------------------------------------------------------------------- /man/shinify.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/main.R 3 | \name{shinify} 4 | \alias{shinify} 5 | \title{Shiny Server} 6 | \usage{ 7 | shinify( 8 | model, 9 | modeltype = "", 10 | variables = c(), 11 | variable_types = c(), 12 | csv_upload = FALSE, 13 | app_title = "Welcome to shinify", 14 | app_theme = "lumen", 15 | input_labels = c(), 16 | output_label = "", 17 | default_input_values = c() 18 | ) 19 | } 20 | \arguments{ 21 | \item{model}{RModel, Your R model used in the prediction on your shiny server.} 22 | 23 | \item{modeltype}{String, Abbreviation of your model type (e.g. "log_reg", "rf"). We are constantly working on adding new models and packages to support with shinify. Look up in jumpstart folder for currently supported models.} 24 | 25 | \item{variables}{Vector, Set name of input variables your model is expecting. Optional if your model has 'model$terms' attribute. NOTE: if values are not equal to model$terms, you will get an error.} 26 | 27 | \item{variable_types}{Vector, Set type of input variables your model is expecting. Optional if your model has 'model$terms' attribute. NOTE: if values are not equal to model$terms, you will get an error.} 28 | 29 | \item{csv_upload}{Boolean, Set TRUE if you want to upload a CSV file as input. Default value is set to FALSE.} 30 | 31 | \item{app_title}{String, Optional: Add a Headline to your shiny server} 32 | 33 | \item{app_theme}{String, Optional: Set the shiny theme you want to use. Default theme is "lumen".} 34 | 35 | \item{input_labels}{Vector, Optional: Set displayed name of your input variables. Does not effect the name of your input variables used in prediction.} 36 | 37 | \item{output_label}{String, Optional: Set displayed name of your output variable. Does not effect the name of your output variable used in prediction.} 38 | 39 | \item{default_input_values}{Vector, Optional: Set default values for your input variables when starting the shiny server.} 40 | } 41 | \description{ 42 | This function creates a shiny server for your model 43 | } 44 | \examples{ 45 | shinify(model) 46 | shinify(model, "log_reg") 47 | shinify(model, "log_reg", app_title = "your awesome title") 48 | shinify(model, "log_reg", app_title = "your awesome title", csv_upload = TRUE) 49 | shinify(model, "dt_party", app_title = "your awesome title", variables = c("attack", "defense"), variable_types = c("numeric", "numeric")) 50 | shinify(model, "dt_party", app_title = "your awesome title", variables = c("attack", "defense"), variable_types = c("numeric", "numeric"), default_input_values = c("180", "290")) 51 | } 52 | \keyword{shiny} 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # shinify 2 | 3 | ## No more coding needed, just add one line to your script in which you call our magic shinify function. 4 | 5 | Shinify automatically creates a shiny server and visual interface for you to interact with your machine learning or statistical model. 6 | 7 | > :warning: This repository is still in an early stage of development and the functions are limited. We are constantly working on adding new models and packages to support with shinify. Take a look in the jumpstart folder for currently supported models and libraries. We love the open source community and want to show what we are working on early. We will update this readme with more information. Until then, feel free to share your thoughts, contact us, and contribute if you'd like. 8 | 9 | --- 10 | 11 | ## How to use 12 | 13 | Install the package from GitHub (If you don't have devtools, install it first: `install.packages("devtools")`): 14 | 15 | ``` 16 | devtools::install_github("stackOcean-official/shinify") 17 | ``` 18 | 19 | In your code load the shinify package and after that, just hand your model over to our `shinify` function to start a R Shiny server and let shinify figure out all the configuration. 20 | 21 | ```r 22 | # load shinify package 23 | library(shinify) 24 | 25 | # do your logistic regression or other algorithms 26 | log_reg <- glm(...) 27 | 28 | # let shinify transform it into a shiny server 29 | shinify(log_reg) 30 | ``` 31 | 32 | ![shinify-example](https://user-images.githubusercontent.com/675065/196923840-11cb971b-990f-46b2-a389-de92e3d1fa44.png) 33 | 34 | Here is the full example for a logistic regression. You can find more examples in the [jumpstart folder](https://github.com/stackOcean-official/shinify/tree/main/jumpstart) 35 | : 36 | 37 | ```r 38 | library(shinify) 39 | 40 | # load data 41 | data <- read.csv("https://github.com/stackOcean-official/hostr/files/9681827/pokemon.csv") 42 | 43 | # create variables 44 | legendary <- data$is_legendary 45 | attack <- data$attack 46 | defense <- data$defense 47 | 48 | # split train and test data 49 | data <- data.frame(legendary, attack, defense) 50 | data_train <- data[1:(nrow(data) - 100), ] 51 | data_test <- data[(nrow(data) - 99):nrow(data), ] 52 | 53 | # actual logistic regression 54 | log_reg <- glm(legendary ~ attack + defense, data = data_train, family = binomial()) 55 | summary(log_reg) 56 | 57 | # input for new prediction 58 | attack <- 120 59 | defense <- 290 60 | test_data_new <- data.frame(attack, defense) 61 | 62 | # definition of a sigmoid function to normalize predictions 63 | sigmoid <- function(x) { 64 | result <- exp(x) / (1 + exp(x)) 65 | return(result) 66 | } 67 | 68 | # actual predicted percentage that pokemon is legendary with glm model 69 | sigmoid(predict(log_reg, test_data_new)) 70 | 71 | # shinify logistic model 72 | shinify(log_reg, modeltype = "log_reg", app_title = "your title here") 73 | 74 | ``` 75 | 76 | Note that you can only host one model at a time in the current development status. 77 | 78 | --- 79 | 80 | After calling the `shinify()` method with the model, a shiny server is started where you can interact with your own model via a graphical interface. 81 | ![shiny-server-preview](https://user-images.githubusercontent.com/28595283/194275509-2faa8937-922a-4006-978e-9f82b0044e04.png) 82 | 83 | ## Shinify function in detail 84 | 85 | The `shinify()` function creates a shiny server for your model 86 | 87 | | Prop | Type | Required | Default | Description | 88 | | --------------------- | --------| -------- | ------------------------ | ------------------------------------------------------------------------------------------------------------------------------- | 89 | | model | model | `yes` | "" | Your R model (output from statistics / machine learning algorithm) | 90 | | modeltype | string | `no` | "" | Abbreviation of your model type that determines. See table below for possible configuration | 91 | | variables | vector | `no` | c() | Set name of input variables your model is expecting for prediction. Optional if your model has 'model$terms' attribute. | 92 | | variable_types | vector | `no` | c() | Set type of input variables your model is expecting for prediction. Optional if your model has 'model$terms' attribute. | 93 | | csv_upload | boolean | `no` | FALSE | Set TRUE if you want to upload a CSV file as input. | 94 | | app_title | string | `no` | "Welcome to shinify" | Add a Headline to your shiny server. | 95 | | app_theme | string | `no` | "lumen" | Set the shiny theme you want to use. | 96 | | input_labels | vector | `no` | c() | Set displayed name of your input variables. Does not effect the name of your input variables used in prediction. | 97 | | output_label | string | `no` | "" | Set displayed name of your output variable. Does not effect the name of your output variable used in prediction. | 98 | | default_input_values | vector | `no` | c() | Set default values for your input variables when starting the shiny server. | 99 | 100 | These are the currently available options for `modeltype`. We are constantly working on adding new models and packages to support with shinify. Please [write an issue](https://github.com/stackOcean-official/shinify/issues/new) if your modeltype is missing 💪 101 | 102 | | modeltype | name of algorithm | 103 | | ---------- | ---------------------- | 104 | | `dt_party` | Decision Tree Party | 105 | | `dr_rpart` | Decision Tree rpart | 106 | | `knn` | k Nearest Neighbors | 107 | | `lin_reg` | Linear Regression | 108 | | `log_reg` | Logistic Regression | 109 | | `svm` | Support Vector Machine | 110 | | `rf` | Random Forest | 111 | 112 | Here are some examples how to call the `shinify` function: 113 | 114 | ```r 115 | # just call shinify with a simple model 116 | shinify(model) 117 | 118 | # call shinify with a log_reg modeltype and the title "awesome discovery" in the shiny app 119 | shinify(model, modeltype="log_reg", app_title = "awesome discovery") 120 | 121 | # call shinify with a svm modeltype and labels for input values 122 | shinify(model, modeltype="svm", app_title = "your awesome title", input_labels = c("Attack Value", "Defense Value")) 123 | 124 | # call shinify with a model that has no model$terms 125 | shinify(model, "dt_party", variables = c("attack", "defense"), variable_types = c("numeric", "numeric")) 126 | ``` 127 | 128 | ## Contributing 129 | 130 | Contributions are what make the open source community such an amazing place to be learn, inspire, and create. Any contributions you make are **greatly appreciated**. 131 | 132 | 1. Fork the project 133 | 2. Create your feature branch (`git checkout -b feature/AmazingFeature`) 134 | 3. Make your changes 135 | 4. Commit your changes (`git commit -m 'Add some AmazingFeature'`) 136 | 5. Push to the branch (`git push origin feature/AmazingFeature`) 137 | 6. Open a pull request 138 | 139 | ## License 140 | 141 | Distributed under the MIT License. See `LICENSE` for more information. 142 | -------------------------------------------------------------------------------- /renv.lock: -------------------------------------------------------------------------------- 1 | { 2 | "R": { 3 | "Version": "4.1.2", 4 | "Repositories": [ 5 | { 6 | "Name": "CRAN", 7 | "URL": "https://cran.rstudio.com" 8 | } 9 | ] 10 | }, 11 | "Packages": { 12 | "R6": { 13 | "Package": "R6", 14 | "Version": "2.5.1", 15 | "Source": "Repository", 16 | "Repository": "CRAN", 17 | "Hash": "470851b6d5d0ac559e9d01bb352b4021", 18 | "Requirements": [] 19 | }, 20 | "Rcpp": { 21 | "Package": "Rcpp", 22 | "Version": "1.0.9", 23 | "Source": "Repository", 24 | "Repository": "CRAN", 25 | "Hash": "e9c08b94391e9f3f97355841229124f2", 26 | "Requirements": [] 27 | }, 28 | "base64enc": { 29 | "Package": "base64enc", 30 | "Version": "0.1-3", 31 | "Source": "Repository", 32 | "Repository": "CRAN", 33 | "Hash": "543776ae6848fde2f48ff3816d0628bc", 34 | "Requirements": [] 35 | }, 36 | "bslib": { 37 | "Package": "bslib", 38 | "Version": "0.4.1", 39 | "Source": "Repository", 40 | "Repository": "CRAN", 41 | "Hash": "89a0cd0c45161e3bd1c1e74a2d65e516", 42 | "Requirements": [ 43 | "cachem", 44 | "htmltools", 45 | "jquerylib", 46 | "jsonlite", 47 | "memoise", 48 | "rlang", 49 | "sass" 50 | ] 51 | }, 52 | "cachem": { 53 | "Package": "cachem", 54 | "Version": "1.0.6", 55 | "Source": "Repository", 56 | "Repository": "CRAN", 57 | "Hash": "648c5b3d71e6a37e3043617489a0a0e9", 58 | "Requirements": [ 59 | "fastmap", 60 | "rlang" 61 | ] 62 | }, 63 | "cli": { 64 | "Package": "cli", 65 | "Version": "3.4.1", 66 | "Source": "Repository", 67 | "Repository": "CRAN", 68 | "Hash": "0d297d01734d2bcea40197bd4971a764", 69 | "Requirements": [] 70 | }, 71 | "commonmark": { 72 | "Package": "commonmark", 73 | "Version": "1.8.1", 74 | "Source": "Repository", 75 | "Repository": "CRAN", 76 | "Hash": "b6e3e947d1d7ebf3d2bdcea1bde63fe7", 77 | "Requirements": [] 78 | }, 79 | "crayon": { 80 | "Package": "crayon", 81 | "Version": "1.5.2", 82 | "Source": "Repository", 83 | "Repository": "CRAN", 84 | "Hash": "e8a1e41acf02548751f45c718d55aa6a", 85 | "Requirements": [] 86 | }, 87 | "digest": { 88 | "Package": "digest", 89 | "Version": "0.6.30", 90 | "Source": "Repository", 91 | "Repository": "CRAN", 92 | "Hash": "bf1cd206a5d170d132ef75c7537b9bdb", 93 | "Requirements": [] 94 | }, 95 | "ellipsis": { 96 | "Package": "ellipsis", 97 | "Version": "0.3.2", 98 | "Source": "Repository", 99 | "Repository": "CRAN", 100 | "Hash": "bb0eec2fe32e88d9e2836c2f73ea2077", 101 | "Requirements": [ 102 | "rlang" 103 | ] 104 | }, 105 | "fastmap": { 106 | "Package": "fastmap", 107 | "Version": "1.1.0", 108 | "Source": "Repository", 109 | "Repository": "CRAN", 110 | "Hash": "77bd60a6157420d4ffa93b27cf6a58b8", 111 | "Requirements": [] 112 | }, 113 | "fontawesome": { 114 | "Package": "fontawesome", 115 | "Version": "0.4.0", 116 | "Source": "Repository", 117 | "Repository": "CRAN", 118 | "Hash": "c5a628c2570aa86a96cc6ef739d8bfda", 119 | "Requirements": [ 120 | "htmltools", 121 | "rlang" 122 | ] 123 | }, 124 | "fs": { 125 | "Package": "fs", 126 | "Version": "1.5.2", 127 | "Source": "Repository", 128 | "Repository": "CRAN", 129 | "Hash": "7c89603d81793f0d5486d91ab1fc6f1d", 130 | "Requirements": [] 131 | }, 132 | "glue": { 133 | "Package": "glue", 134 | "Version": "1.6.2", 135 | "Source": "Repository", 136 | "Repository": "CRAN", 137 | "Hash": "4f2596dfb05dac67b9dc558e5c6fba2e", 138 | "Requirements": [] 139 | }, 140 | "htmltools": { 141 | "Package": "htmltools", 142 | "Version": "0.5.3", 143 | "Source": "Repository", 144 | "Repository": "CRAN", 145 | "Hash": "6496090a9e00f8354b811d1a2d47b566", 146 | "Requirements": [ 147 | "base64enc", 148 | "digest", 149 | "fastmap", 150 | "rlang" 151 | ] 152 | }, 153 | "httpuv": { 154 | "Package": "httpuv", 155 | "Version": "1.6.6", 156 | "Source": "Repository", 157 | "Repository": "CRAN", 158 | "Hash": "fd090e236ae2dc0f0cdf33a9ec83afb6", 159 | "Requirements": [ 160 | "R6", 161 | "Rcpp", 162 | "later", 163 | "promises" 164 | ] 165 | }, 166 | "jquerylib": { 167 | "Package": "jquerylib", 168 | "Version": "0.1.4", 169 | "Source": "Repository", 170 | "Repository": "CRAN", 171 | "Hash": "5aab57a3bd297eee1c1d862735972182", 172 | "Requirements": [ 173 | "htmltools" 174 | ] 175 | }, 176 | "jsonlite": { 177 | "Package": "jsonlite", 178 | "Version": "1.8.3", 179 | "Source": "Repository", 180 | "Repository": "CRAN", 181 | "Hash": "8b1bd0be62956f2a6b91ce84fac79a45", 182 | "Requirements": [] 183 | }, 184 | "later": { 185 | "Package": "later", 186 | "Version": "1.3.0", 187 | "Source": "Repository", 188 | "Repository": "CRAN", 189 | "Hash": "7e7b457d7766bc47f2a5f21cc2984f8e", 190 | "Requirements": [ 191 | "Rcpp", 192 | "rlang" 193 | ] 194 | }, 195 | "lifecycle": { 196 | "Package": "lifecycle", 197 | "Version": "1.0.3", 198 | "Source": "Repository", 199 | "Repository": "CRAN", 200 | "Hash": "001cecbeac1cff9301bdc3775ee46a86", 201 | "Requirements": [ 202 | "cli", 203 | "glue", 204 | "rlang" 205 | ] 206 | }, 207 | "magrittr": { 208 | "Package": "magrittr", 209 | "Version": "2.0.3", 210 | "Source": "Repository", 211 | "Repository": "CRAN", 212 | "Hash": "7ce2733a9826b3aeb1775d56fd305472", 213 | "Requirements": [] 214 | }, 215 | "memoise": { 216 | "Package": "memoise", 217 | "Version": "2.0.1", 218 | "Source": "Repository", 219 | "Repository": "CRAN", 220 | "Hash": "e2817ccf4a065c5d9d7f2cfbe7c1d78c", 221 | "Requirements": [ 222 | "cachem", 223 | "rlang" 224 | ] 225 | }, 226 | "mime": { 227 | "Package": "mime", 228 | "Version": "0.12", 229 | "Source": "Repository", 230 | "Repository": "CRAN", 231 | "Hash": "18e9c28c1d3ca1560ce30658b22ce104", 232 | "Requirements": [] 233 | }, 234 | "promises": { 235 | "Package": "promises", 236 | "Version": "1.2.0.1", 237 | "Source": "Repository", 238 | "Repository": "CRAN", 239 | "Hash": "4ab2c43adb4d4699cf3690acd378d75d", 240 | "Requirements": [ 241 | "R6", 242 | "Rcpp", 243 | "later", 244 | "magrittr", 245 | "rlang" 246 | ] 247 | }, 248 | "rappdirs": { 249 | "Package": "rappdirs", 250 | "Version": "0.3.3", 251 | "Source": "Repository", 252 | "Repository": "CRAN", 253 | "Hash": "5e3c5dc0b071b21fa128676560dbe94d", 254 | "Requirements": [] 255 | }, 256 | "renv": { 257 | "Package": "renv", 258 | "Version": "0.16.0", 259 | "Source": "Repository", 260 | "Repository": "CRAN", 261 | "Hash": "c9e8442ab69bc21c9697ecf856c1e6c7", 262 | "Requirements": [] 263 | }, 264 | "rlang": { 265 | "Package": "rlang", 266 | "Version": "1.0.6", 267 | "Source": "Repository", 268 | "Repository": "CRAN", 269 | "Hash": "4ed1f8336c8d52c3e750adcdc57228a7", 270 | "Requirements": [] 271 | }, 272 | "rpart": { 273 | "Package": "rpart", 274 | "Version": "4.1.19", 275 | "Source": "Repository", 276 | "Repository": "CRAN", 277 | "Hash": "b3c892a81783376cc2204af0f5805a80", 278 | "Requirements": [] 279 | }, 280 | "sass": { 281 | "Package": "sass", 282 | "Version": "0.4.2", 283 | "Source": "Repository", 284 | "Repository": "CRAN", 285 | "Hash": "1b191143d7d3444d504277843f3a95fe", 286 | "Requirements": [ 287 | "R6", 288 | "fs", 289 | "htmltools", 290 | "rappdirs", 291 | "rlang" 292 | ] 293 | }, 294 | "shiny": { 295 | "Package": "shiny", 296 | "Version": "1.7.3", 297 | "Source": "Repository", 298 | "Repository": "CRAN", 299 | "Hash": "fe12df67fdb3b1142325cc54f100cc06", 300 | "Requirements": [ 301 | "R6", 302 | "bslib", 303 | "cachem", 304 | "commonmark", 305 | "crayon", 306 | "ellipsis", 307 | "fastmap", 308 | "fontawesome", 309 | "glue", 310 | "htmltools", 311 | "httpuv", 312 | "jsonlite", 313 | "later", 314 | "lifecycle", 315 | "mime", 316 | "promises", 317 | "rlang", 318 | "sourcetools", 319 | "withr", 320 | "xtable" 321 | ] 322 | }, 323 | "shinythemes": { 324 | "Package": "shinythemes", 325 | "Version": "1.2.0", 326 | "Source": "Repository", 327 | "Repository": "CRAN", 328 | "Hash": "30f0ebc41feba25691073626ff5e2cf4", 329 | "Requirements": [ 330 | "shiny" 331 | ] 332 | }, 333 | "sourcetools": { 334 | "Package": "sourcetools", 335 | "Version": "0.1.7", 336 | "Source": "Repository", 337 | "Repository": "CRAN", 338 | "Hash": "947e4e02a79effa5d512473e10f41797", 339 | "Requirements": [] 340 | }, 341 | "withr": { 342 | "Package": "withr", 343 | "Version": "2.5.0", 344 | "Source": "Repository", 345 | "Repository": "CRAN", 346 | "Hash": "c0e49a9760983e81e55cdd9be92e7182", 347 | "Requirements": [] 348 | }, 349 | "xtable": { 350 | "Package": "xtable", 351 | "Version": "1.8-4", 352 | "Source": "Repository", 353 | "Repository": "CRAN", 354 | "Hash": "b8acdf8af494d9ec19ccb2481a9b11c2", 355 | "Requirements": [] 356 | } 357 | } 358 | } 359 | -------------------------------------------------------------------------------- /R/main.R: -------------------------------------------------------------------------------- 1 | # Some useful keyboard shortcuts for package authoring: 2 | # 3 | # Install Package: 'Cmd + Shift + B' 4 | # Check Package: 'Cmd + Shift + E' 5 | # Test Package: 'Cmd + Shift + T' 6 | 7 | #' Shiny Server 8 | #' 9 | #' This function creates a shiny server for your model 10 | #' @param model RModel, Your R model used in the prediction on your shiny server. 11 | #' @param modeltype String, Abbreviation of your model type (e.g. "log_reg", "rf"). We are constantly working on adding new models and packages to support with shinify. Look up in jumpstart folder for currently supported models. 12 | #' @param variables Vector, Set name of input variables your model is expecting. Optional if your model has 'model$terms' attribute. NOTE: if values are not equal to model$terms, you will get an error. 13 | #' @param variable_types Vector, Set type of input variables your model is expecting. Optional if your model has 'model$terms' attribute. NOTE: if values are not equal to model$terms, you will get an error. 14 | #' @param csv_upload Boolean, Set TRUE if you want to upload a CSV file as input. Default value is set to FALSE. 15 | #' @param app_title String, Optional: Add a Headline to your shiny server 16 | #' @param app_theme String, Optional: Set the shiny theme you want to use. Default theme is "lumen". 17 | #' @param input_labels Vector, Optional: Set displayed name of your input variables. Does not effect the name of your input variables used in prediction. 18 | #' @param output_label String, Optional: Set displayed name of your output variable. Does not effect the name of your output variable used in prediction. 19 | #' @param default_input_values Vector, Optional: Set default values for your input variables when starting the shiny server. 20 | #' @keywords shiny 21 | #' @export 22 | #' @examples 23 | #' shinify(model) 24 | #' shinify(model, "log_reg") 25 | #' shinify(model, "log_reg", app_title = "your awesome title") 26 | #' shinify(model, "log_reg", app_title = "your awesome title", csv_upload = TRUE) 27 | #' shinify(model, "dt_party", app_title = "your awesome title", variables = c("attack", "defense"), variable_types = c("numeric", "numeric")) 28 | #' shinify(model, "dt_party", app_title = "your awesome title", variables = c("attack", "defense"), variable_types = c("numeric", "numeric"), default_input_values = c("180", "290")) 29 | #' @importFrom stats predict 30 | #' @importFrom utils install.packages read.csv write.csv 31 | 32 | 33 | shinify <- function(model, modeltype = "", variables = c(), variable_types = c(), csv_upload = FALSE, app_title = "Welcome to shinify", app_theme = "lumen", input_labels = c(), output_label = "", default_input_values = c()) { 34 | # load required packages depending on the modeltype 35 | requiredPackages(modeltype) 36 | 37 | # set port for shiny server 38 | options(shiny.port = 8000) 39 | options(shiny.host = "0.0.0.0") 40 | 41 | ################################################ 42 | ## Check arguments and set internal variables ## 43 | ################################################ 44 | 45 | if (nchar(modeltype) < 1) { 46 | warning("Warning: You have not passed the type of yor model. The passed modeltype effects your prediction and output values. The default modeltype is set to linear regression.") 47 | } 48 | 49 | # Stop if the number of model input names and type does not match up. 50 | if (!is.null(variables) && !is.null(variable_types)) { 51 | if (length(variables) != length(variable_types)) { 52 | stop("Missmatch: The number of set names and types for model variables do not matchup.") 53 | } 54 | } 55 | 56 | if (xor(!is.null(variables), !is.null(variable_types))) { 57 | stop_msg <- "Error in shinify(): \n" 58 | if (!is.null(variables)) { 59 | stop_msg <- paste(stop_msg, "You have set the name for your variables, but not the type. Please add the 'varible_types' parameter.") 60 | } else { 61 | stop_msg <- paste(stop_msg, "You have set the type for your variables, but not the name Please add the 'varibles' parameter.") 62 | } 63 | stop(stop_msg) 64 | } 65 | 66 | # check for the type of independent variables. If not set by the user, we get them from the model. 67 | if (is.null(variable_types)) { 68 | input_type <- tryCatch( 69 | { 70 | paste(attr(model$terms, "dataClasses"))[-1] 71 | }, 72 | error = function(e) { 73 | stop_msg <- "Error in shinify(): \n Your passed model does not contain the following information: model$terms." 74 | stop_msg <- paste(stop_msg, "\n Consider adding the vector `variable_types`.") 75 | if (is.null(variables)) { 76 | stop_msg <- paste(stop_msg, "\n Consider adding the vector `variables`.") 77 | } 78 | message(stop_msg) 79 | message("Here's the original error message:") 80 | message(e) 81 | } 82 | ) 83 | } else { 84 | input_type <- sapply(variable_types, function(x) { 85 | if (tolower(x) == "numeric" || tolower(x) == "num" || tolower(x) == "integer" || tolower(x) == "int" || tolower(x) == "double") { 86 | return("numeric") 87 | } else if (tolower(x) == "string" || tolower(x) == "character") { 88 | return("character") 89 | } else if (tolower(x) == "factor") { 90 | return("factor") 91 | } else { 92 | stop("Error in shinify(): \n Your 'variable_types' do not meet the requirements of shinify(). \n You can choose between numeric, character and factor types.") 93 | } 94 | }) 95 | } 96 | 97 | # check for the name of independent variables. If not set by the user, we get them from the model. 98 | if (is.null(variables)) { 99 | model_terms <- paste(attr(model$terms, "predvars"))[-1] 100 | } else { 101 | model_terms <- c("output", variables) 102 | } 103 | 104 | # the user can set the displayed name of his input and output variables. If not set by the user, they will be equal to the names of his model-terms 105 | if (is.null(input_labels)) { 106 | input_label <- model_terms[-1] 107 | } else { 108 | input_label <- input_labels 109 | } 110 | 111 | if (nchar(output_label) < 1) { 112 | output_label <- model_terms[1] 113 | } else { 114 | output_label <- output_label 115 | } 116 | 117 | input_count <- length(input_label) 118 | 119 | # the user can set default values for his input variables. If not set by the user, they will be 0 for numeric and "Text" for character and factor variables. 120 | if (is.null(default_input_values)) { 121 | input_values <- c() 122 | for (i in seq(input_count)) { 123 | if (input_type[i] == "numeric") { 124 | input_values[i] <- 0 125 | } else { 126 | input_values[i] <- "Text" 127 | } 128 | } 129 | } else { 130 | input_values <- default_input_values 131 | } 132 | 133 | ################################################ 134 | ## Define UI ## 135 | ################################################ 136 | ui <- fluidPage( 137 | theme = shinytheme(app_theme), 138 | titlePanel(app_title), 139 | # Build the sidebar / input section depending on the input type. For CSV we create a file-upload and a download button. For single varibales we create input fields. 140 | sidebarLayout( 141 | if (csv_upload) { 142 | sidebarPanel( 143 | textInput(inputId = "sep", label = "seperator", value = ";"), 144 | checkboxInput("header", "Header", TRUE), 145 | fileInput("upload", "Choose CSV File", 146 | accept = c( 147 | "text/csv", 148 | "text/comma-separated-values,text/plain", 149 | ".csv" 150 | ) 151 | ), 152 | downloadButton("download") 153 | ) 154 | } else { 155 | sidebarPanel( 156 | # multiple inputs depending on number of expected inputs from the model and the type of each input 157 | inputs <- lapply(1:input_count, function(i) { 158 | if (input_type[i] == "numeric") { 159 | numericInput(inputId = paste0("num", i), label = input_label[i], value = as.numeric(input_values[i])) 160 | } else if (input_type[i] == "factor" || input_type[i] == "character") { 161 | textInput(inputId = paste0("num", i), label = input_label[i], value = input_values[i]) 162 | } 163 | }) 164 | ) 165 | }, 166 | 167 | # Build the main panel / output section depending on the input type. For CSV we create a table of the input csv and a row of outputs. For single variables we create a textfield that displays the result. 168 | if (csv_upload) { 169 | mainPanel( 170 | tags$a(href = "https://stackocean.com", "provided by stackOcean", target = "_blank"), 171 | h2("Table"), 172 | tableOutput("contents") 173 | ) 174 | } else { 175 | mainPanel( 176 | h2(output_label), 177 | h2(textOutput(outputId = "prediction")), 178 | tags$a(href = "https://stackocean.com", "provided by stackOcean", target = "_blank") 179 | ) 180 | } 181 | ) 182 | ) 183 | 184 | ################################################ 185 | ## Define Server Function ## 186 | ################################################ 187 | server <- function(input, output, session) { 188 | # Load server functions depending on the input. For CSV we start a reactive Function to read an uploaded csv and addend a column with predicted output 189 | if (csv_upload) { 190 | csv_data <- reactive({ 191 | inFile <- input$upload 192 | if (is.null(inFile)) { 193 | return(NULL) 194 | } 195 | csv_data <- read.csv(inFile$datapath, header = input$header, sep = input$sep) 196 | csv_data$output <- predict(model, newdata = csv_data) 197 | csv_data$output <- checkModeltypeRequirements(csv_data$output, modeltype, csv_upload) 198 | colnames(csv_data)[ncol(csv_data)] <- output_label 199 | csv_data 200 | }) 201 | } 202 | # Only if input is CSV: Render table of input CSV with additional column of predicted values 203 | output$contents <- renderTable({ 204 | output <- csv_data() 205 | }) 206 | # Only if input is CSV: Download button to download table of Input CSV with additional Column of predicted values 207 | output$download <- downloadHandler( 208 | filename = function() { 209 | paste0("results", ".csv") 210 | }, 211 | content = function(file) { 212 | write.csv(csv_data(), file) 213 | } 214 | ) 215 | # If input is NOT CSV: Predicts value for given input variables. Therefore we create a data frame of one row containing the given input values. 216 | output$prediction <- renderText({ 217 | df <- data.frame(matrix(ncol = input_count, nrow = 0)) 218 | colnames(df) <- model_terms[-1] 219 | df[1, ] <- sapply(1:input_count, function(i) { 220 | req(input[[paste0("num", i)]]) 221 | input[[paste0("num", i)]] 222 | }) 223 | # actual predict function and additional function call for sigmoid if needed 224 | predicted_output <- tryCatch( 225 | { 226 | predict(model, newdata = df) 227 | }, 228 | error = function(e) { 229 | message("Error in shinify(): \n Your passed values do not match with your model. NOTE: the column names of your training data have to match the 'variables' names.") 230 | message("Here's the original warning message:") 231 | message(e) 232 | } 233 | ) 234 | predicted_output <- checkModeltypeRequirements(predicted_output, modeltype) 235 | paste(round(predicted_output, digits = 4)) 236 | }) 237 | } 238 | 239 | ################################################ 240 | ## Create Shiny Object ## 241 | ################################################ 242 | shinyApp(ui = ui, server = server) 243 | } 244 | 245 | ################################################ 246 | ## Additional Function Calls ## 247 | ################################################ 248 | # prepare output depending on the requirements by each ml model 249 | checkModeltypeRequirements <- function(predicted_output, modeltype, csv_upload) { 250 | if (modeltype == "log_reg") { 251 | predicted_output <- sigmoid(predicted_output) 252 | } 253 | if (modeltype == "dt_rpart") { 254 | if (csv_upload) { 255 | predicted_output <- predicted_output[ ,2] 256 | } else { 257 | predicted_output <- predicted_output[2] 258 | } 259 | } 260 | return(predicted_output) 261 | } 262 | 263 | # sigmoid function to correct output if using a log_reg 264 | sigmoid <- function(x) { 265 | result <- exp(x) / (1 + exp(x)) 266 | return(result) 267 | } 268 | 269 | # function to load all required packages 270 | requiredPackages <- function(modeltype) { 271 | if (!requireNamespace("shiny", quietly = TRUE)) { 272 | install.packages("shiny", repos = "http://cran.us.r-project.org") 273 | } 274 | if (!requireNamespace("shinythemes", quietly = TRUE)) { 275 | install.packages("shinythemes", repos = "http://cran.us.r-project.org") 276 | } 277 | if (modeltype == "dt_rpart" && !requireNamespace("rpart", quietly = TRUE)) { 278 | install.packages("rpart", repos = "http://cran.us.r-project.org") 279 | library(rpart) 280 | } 281 | if (modeltype == "dt_party" && !requireNamespace("party", quietly = TRUE)) { 282 | install.packages("party", repos = "http://cran.us.r-project.org") 283 | library(party) 284 | } 285 | if (modeltype == "svm" && !requireNamespace("e1071", quietly = TRUE)) { 286 | install.packages("e1071", repos = "http://cran.us.r-project.org") 287 | library(e1071) 288 | } 289 | if (modeltype == "rf" && !requireNamespace("randomForest", quietly = TRUE)) { 290 | install.packages("randomForest", repos = "http://cran.us.r-project.org") 291 | library(randomForest) 292 | } 293 | library(shiny) 294 | library(shinythemes) 295 | } 296 | -------------------------------------------------------------------------------- /renv/activate.R: -------------------------------------------------------------------------------- 1 | 2 | local({ 3 | 4 | # the requested version of renv 5 | version <- "0.16.0" 6 | 7 | # the project directory 8 | project <- getwd() 9 | 10 | # figure out whether the autoloader is enabled 11 | enabled <- local({ 12 | 13 | # first, check config option 14 | override <- getOption("renv.config.autoloader.enabled") 15 | if (!is.null(override)) 16 | return(override) 17 | 18 | # next, check environment variables 19 | # TODO: prefer using the configuration one in the future 20 | envvars <- c( 21 | "RENV_CONFIG_AUTOLOADER_ENABLED", 22 | "RENV_AUTOLOADER_ENABLED", 23 | "RENV_ACTIVATE_PROJECT" 24 | ) 25 | 26 | for (envvar in envvars) { 27 | envval <- Sys.getenv(envvar, unset = NA) 28 | if (!is.na(envval)) 29 | return(tolower(envval) %in% c("true", "t", "1")) 30 | } 31 | 32 | # enable by default 33 | TRUE 34 | 35 | }) 36 | 37 | if (!enabled) 38 | return(FALSE) 39 | 40 | # avoid recursion 41 | if (identical(getOption("renv.autoloader.running"), TRUE)) { 42 | warning("ignoring recursive attempt to run renv autoloader") 43 | return(invisible(TRUE)) 44 | } 45 | 46 | # signal that we're loading renv during R startup 47 | options(renv.autoloader.running = TRUE) 48 | on.exit(options(renv.autoloader.running = NULL), add = TRUE) 49 | 50 | # signal that we've consented to use renv 51 | options(renv.consent = TRUE) 52 | 53 | # load the 'utils' package eagerly -- this ensures that renv shims, which 54 | # mask 'utils' packages, will come first on the search path 55 | library(utils, lib.loc = .Library) 56 | 57 | # unload renv if it's already been loaded 58 | if ("renv" %in% loadedNamespaces()) 59 | unloadNamespace("renv") 60 | 61 | # load bootstrap tools 62 | `%||%` <- function(x, y) { 63 | if (is.environment(x) || length(x)) x else y 64 | } 65 | 66 | bootstrap <- function(version, library) { 67 | 68 | # attempt to download renv 69 | tarball <- tryCatch(renv_bootstrap_download(version), error = identity) 70 | if (inherits(tarball, "error")) 71 | stop("failed to download renv ", version) 72 | 73 | # now attempt to install 74 | status <- tryCatch(renv_bootstrap_install(version, tarball, library), error = identity) 75 | if (inherits(status, "error")) 76 | stop("failed to install renv ", version) 77 | 78 | } 79 | 80 | renv_bootstrap_tests_running <- function() { 81 | getOption("renv.tests.running", default = FALSE) 82 | } 83 | 84 | renv_bootstrap_repos <- function() { 85 | 86 | # check for repos override 87 | repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) 88 | if (!is.na(repos)) 89 | return(repos) 90 | 91 | # check for lockfile repositories 92 | repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) 93 | if (!inherits(repos, "error") && length(repos)) 94 | return(repos) 95 | 96 | # if we're testing, re-use the test repositories 97 | if (renv_bootstrap_tests_running()) 98 | return(getOption("renv.tests.repos")) 99 | 100 | # retrieve current repos 101 | repos <- getOption("repos") 102 | 103 | # ensure @CRAN@ entries are resolved 104 | repos[repos == "@CRAN@"] <- getOption( 105 | "renv.repos.cran", 106 | "https://cloud.r-project.org" 107 | ) 108 | 109 | # add in renv.bootstrap.repos if set 110 | default <- c(FALLBACK = "https://cloud.r-project.org") 111 | extra <- getOption("renv.bootstrap.repos", default = default) 112 | repos <- c(repos, extra) 113 | 114 | # remove duplicates that might've snuck in 115 | dupes <- duplicated(repos) | duplicated(names(repos)) 116 | repos[!dupes] 117 | 118 | } 119 | 120 | renv_bootstrap_repos_lockfile <- function() { 121 | 122 | lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") 123 | if (!file.exists(lockpath)) 124 | return(NULL) 125 | 126 | lockfile <- tryCatch(renv_json_read(lockpath), error = identity) 127 | if (inherits(lockfile, "error")) { 128 | warning(lockfile) 129 | return(NULL) 130 | } 131 | 132 | repos <- lockfile$R$Repositories 133 | if (length(repos) == 0) 134 | return(NULL) 135 | 136 | keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) 137 | vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) 138 | names(vals) <- keys 139 | 140 | return(vals) 141 | 142 | } 143 | 144 | renv_bootstrap_download <- function(version) { 145 | 146 | # if the renv version number has 4 components, assume it must 147 | # be retrieved via github 148 | nv <- numeric_version(version) 149 | components <- unclass(nv)[[1]] 150 | 151 | # if this appears to be a development version of 'renv', we'll 152 | # try to restore from github 153 | dev <- length(components) == 4L 154 | 155 | # begin collecting different methods for finding renv 156 | methods <- c( 157 | renv_bootstrap_download_tarball, 158 | if (dev) 159 | renv_bootstrap_download_github 160 | else c( 161 | renv_bootstrap_download_cran_latest, 162 | renv_bootstrap_download_cran_archive 163 | ) 164 | ) 165 | 166 | for (method in methods) { 167 | path <- tryCatch(method(version), error = identity) 168 | if (is.character(path) && file.exists(path)) 169 | return(path) 170 | } 171 | 172 | stop("failed to download renv ", version) 173 | 174 | } 175 | 176 | renv_bootstrap_download_impl <- function(url, destfile) { 177 | 178 | mode <- "wb" 179 | 180 | # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 181 | fixup <- 182 | Sys.info()[["sysname"]] == "Windows" && 183 | substring(url, 1L, 5L) == "file:" 184 | 185 | if (fixup) 186 | mode <- "w+b" 187 | 188 | args <- list( 189 | url = url, 190 | destfile = destfile, 191 | mode = mode, 192 | quiet = TRUE 193 | ) 194 | 195 | if ("headers" %in% names(formals(utils::download.file))) 196 | args$headers <- renv_bootstrap_download_custom_headers(url) 197 | 198 | do.call(utils::download.file, args) 199 | 200 | } 201 | 202 | renv_bootstrap_download_custom_headers <- function(url) { 203 | 204 | headers <- getOption("renv.download.headers") 205 | if (is.null(headers)) 206 | return(character()) 207 | 208 | if (!is.function(headers)) 209 | stopf("'renv.download.headers' is not a function") 210 | 211 | headers <- headers(url) 212 | if (length(headers) == 0L) 213 | return(character()) 214 | 215 | if (is.list(headers)) 216 | headers <- unlist(headers, recursive = FALSE, use.names = TRUE) 217 | 218 | ok <- 219 | is.character(headers) && 220 | is.character(names(headers)) && 221 | all(nzchar(names(headers))) 222 | 223 | if (!ok) 224 | stop("invocation of 'renv.download.headers' did not return a named character vector") 225 | 226 | headers 227 | 228 | } 229 | 230 | renv_bootstrap_download_cran_latest <- function(version) { 231 | 232 | spec <- renv_bootstrap_download_cran_latest_find(version) 233 | type <- spec$type 234 | repos <- spec$repos 235 | 236 | message("* Downloading renv ", version, " ... ", appendLF = FALSE) 237 | 238 | baseurl <- utils::contrib.url(repos = repos, type = type) 239 | ext <- if (identical(type, "source")) 240 | ".tar.gz" 241 | else if (Sys.info()[["sysname"]] == "Windows") 242 | ".zip" 243 | else 244 | ".tgz" 245 | name <- sprintf("renv_%s%s", version, ext) 246 | url <- paste(baseurl, name, sep = "/") 247 | 248 | destfile <- file.path(tempdir(), name) 249 | status <- tryCatch( 250 | renv_bootstrap_download_impl(url, destfile), 251 | condition = identity 252 | ) 253 | 254 | if (inherits(status, "condition")) { 255 | message("FAILED") 256 | return(FALSE) 257 | } 258 | 259 | # report success and return 260 | message("OK (downloaded ", type, ")") 261 | destfile 262 | 263 | } 264 | 265 | renv_bootstrap_download_cran_latest_find <- function(version) { 266 | 267 | # check whether binaries are supported on this system 268 | binary <- 269 | getOption("renv.bootstrap.binary", default = TRUE) && 270 | !identical(.Platform$pkgType, "source") && 271 | !identical(getOption("pkgType"), "source") && 272 | Sys.info()[["sysname"]] %in% c("Darwin", "Windows") 273 | 274 | types <- c(if (binary) "binary", "source") 275 | 276 | # iterate over types + repositories 277 | for (type in types) { 278 | for (repos in renv_bootstrap_repos()) { 279 | 280 | # retrieve package database 281 | db <- tryCatch( 282 | as.data.frame( 283 | utils::available.packages(type = type, repos = repos), 284 | stringsAsFactors = FALSE 285 | ), 286 | error = identity 287 | ) 288 | 289 | if (inherits(db, "error")) 290 | next 291 | 292 | # check for compatible entry 293 | entry <- db[db$Package %in% "renv" & db$Version %in% version, ] 294 | if (nrow(entry) == 0) 295 | next 296 | 297 | # found it; return spec to caller 298 | spec <- list(entry = entry, type = type, repos = repos) 299 | return(spec) 300 | 301 | } 302 | } 303 | 304 | # if we got here, we failed to find renv 305 | fmt <- "renv %s is not available from your declared package repositories" 306 | stop(sprintf(fmt, version)) 307 | 308 | } 309 | 310 | renv_bootstrap_download_cran_archive <- function(version) { 311 | 312 | name <- sprintf("renv_%s.tar.gz", version) 313 | repos <- renv_bootstrap_repos() 314 | urls <- file.path(repos, "src/contrib/Archive/renv", name) 315 | destfile <- file.path(tempdir(), name) 316 | 317 | message("* Downloading renv ", version, " ... ", appendLF = FALSE) 318 | 319 | for (url in urls) { 320 | 321 | status <- tryCatch( 322 | renv_bootstrap_download_impl(url, destfile), 323 | condition = identity 324 | ) 325 | 326 | if (identical(status, 0L)) { 327 | message("OK") 328 | return(destfile) 329 | } 330 | 331 | } 332 | 333 | message("FAILED") 334 | return(FALSE) 335 | 336 | } 337 | 338 | renv_bootstrap_download_tarball <- function(version) { 339 | 340 | # if the user has provided the path to a tarball via 341 | # an environment variable, then use it 342 | tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) 343 | if (is.na(tarball)) 344 | return() 345 | 346 | # allow directories 347 | info <- file.info(tarball, extra_cols = FALSE) 348 | if (identical(info$isdir, TRUE)) { 349 | name <- sprintf("renv_%s.tar.gz", version) 350 | tarball <- file.path(tarball, name) 351 | } 352 | 353 | # bail if it doesn't exist 354 | if (!file.exists(tarball)) { 355 | 356 | # let the user know we weren't able to honour their request 357 | fmt <- "* RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." 358 | msg <- sprintf(fmt, tarball) 359 | warning(msg) 360 | 361 | # bail 362 | return() 363 | 364 | } 365 | 366 | fmt <- "* Bootstrapping with tarball at path '%s'." 367 | msg <- sprintf(fmt, tarball) 368 | message(msg) 369 | 370 | tarball 371 | 372 | } 373 | 374 | renv_bootstrap_download_github <- function(version) { 375 | 376 | enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") 377 | if (!identical(enabled, "TRUE")) 378 | return(FALSE) 379 | 380 | # prepare download options 381 | pat <- Sys.getenv("GITHUB_PAT") 382 | if (nzchar(Sys.which("curl")) && nzchar(pat)) { 383 | fmt <- "--location --fail --header \"Authorization: token %s\"" 384 | extra <- sprintf(fmt, pat) 385 | saved <- options("download.file.method", "download.file.extra") 386 | options(download.file.method = "curl", download.file.extra = extra) 387 | on.exit(do.call(base::options, saved), add = TRUE) 388 | } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { 389 | fmt <- "--header=\"Authorization: token %s\"" 390 | extra <- sprintf(fmt, pat) 391 | saved <- options("download.file.method", "download.file.extra") 392 | options(download.file.method = "wget", download.file.extra = extra) 393 | on.exit(do.call(base::options, saved), add = TRUE) 394 | } 395 | 396 | message("* Downloading renv ", version, " from GitHub ... ", appendLF = FALSE) 397 | 398 | url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) 399 | name <- sprintf("renv_%s.tar.gz", version) 400 | destfile <- file.path(tempdir(), name) 401 | 402 | status <- tryCatch( 403 | renv_bootstrap_download_impl(url, destfile), 404 | condition = identity 405 | ) 406 | 407 | if (!identical(status, 0L)) { 408 | message("FAILED") 409 | return(FALSE) 410 | } 411 | 412 | message("OK") 413 | return(destfile) 414 | 415 | } 416 | 417 | renv_bootstrap_install <- function(version, tarball, library) { 418 | 419 | # attempt to install it into project library 420 | message("* Installing renv ", version, " ... ", appendLF = FALSE) 421 | dir.create(library, showWarnings = FALSE, recursive = TRUE) 422 | 423 | # invoke using system2 so we can capture and report output 424 | bin <- R.home("bin") 425 | exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" 426 | r <- file.path(bin, exe) 427 | 428 | args <- c( 429 | "--vanilla", "CMD", "INSTALL", "--no-multiarch", 430 | "-l", shQuote(path.expand(library)), 431 | shQuote(path.expand(tarball)) 432 | ) 433 | 434 | output <- system2(r, args, stdout = TRUE, stderr = TRUE) 435 | message("Done!") 436 | 437 | # check for successful install 438 | status <- attr(output, "status") 439 | if (is.numeric(status) && !identical(status, 0L)) { 440 | header <- "Error installing renv:" 441 | lines <- paste(rep.int("=", nchar(header)), collapse = "") 442 | text <- c(header, lines, output) 443 | writeLines(text, con = stderr()) 444 | } 445 | 446 | status 447 | 448 | } 449 | 450 | renv_bootstrap_platform_prefix <- function() { 451 | 452 | # construct version prefix 453 | version <- paste(R.version$major, R.version$minor, sep = ".") 454 | prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") 455 | 456 | # include SVN revision for development versions of R 457 | # (to avoid sharing platform-specific artefacts with released versions of R) 458 | devel <- 459 | identical(R.version[["status"]], "Under development (unstable)") || 460 | identical(R.version[["nickname"]], "Unsuffered Consequences") 461 | 462 | if (devel) 463 | prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") 464 | 465 | # build list of path components 466 | components <- c(prefix, R.version$platform) 467 | 468 | # include prefix if provided by user 469 | prefix <- renv_bootstrap_platform_prefix_impl() 470 | if (!is.na(prefix) && nzchar(prefix)) 471 | components <- c(prefix, components) 472 | 473 | # build prefix 474 | paste(components, collapse = "/") 475 | 476 | } 477 | 478 | renv_bootstrap_platform_prefix_impl <- function() { 479 | 480 | # if an explicit prefix has been supplied, use it 481 | prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) 482 | if (!is.na(prefix)) 483 | return(prefix) 484 | 485 | # if the user has requested an automatic prefix, generate it 486 | auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) 487 | if (auto %in% c("TRUE", "True", "true", "1")) 488 | return(renv_bootstrap_platform_prefix_auto()) 489 | 490 | # empty string on failure 491 | "" 492 | 493 | } 494 | 495 | renv_bootstrap_platform_prefix_auto <- function() { 496 | 497 | prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) 498 | if (inherits(prefix, "error") || prefix %in% "unknown") { 499 | 500 | msg <- paste( 501 | "failed to infer current operating system", 502 | "please file a bug report at https://github.com/rstudio/renv/issues", 503 | sep = "; " 504 | ) 505 | 506 | warning(msg) 507 | 508 | } 509 | 510 | prefix 511 | 512 | } 513 | 514 | renv_bootstrap_platform_os <- function() { 515 | 516 | sysinfo <- Sys.info() 517 | sysname <- sysinfo[["sysname"]] 518 | 519 | # handle Windows + macOS up front 520 | if (sysname == "Windows") 521 | return("windows") 522 | else if (sysname == "Darwin") 523 | return("macos") 524 | 525 | # check for os-release files 526 | for (file in c("/etc/os-release", "/usr/lib/os-release")) 527 | if (file.exists(file)) 528 | return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) 529 | 530 | # check for redhat-release files 531 | if (file.exists("/etc/redhat-release")) 532 | return(renv_bootstrap_platform_os_via_redhat_release()) 533 | 534 | "unknown" 535 | 536 | } 537 | 538 | renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { 539 | 540 | # read /etc/os-release 541 | release <- utils::read.table( 542 | file = file, 543 | sep = "=", 544 | quote = c("\"", "'"), 545 | col.names = c("Key", "Value"), 546 | comment.char = "#", 547 | stringsAsFactors = FALSE 548 | ) 549 | 550 | vars <- as.list(release$Value) 551 | names(vars) <- release$Key 552 | 553 | # get os name 554 | os <- tolower(sysinfo[["sysname"]]) 555 | 556 | # read id 557 | id <- "unknown" 558 | for (field in c("ID", "ID_LIKE")) { 559 | if (field %in% names(vars) && nzchar(vars[[field]])) { 560 | id <- vars[[field]] 561 | break 562 | } 563 | } 564 | 565 | # read version 566 | version <- "unknown" 567 | for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { 568 | if (field %in% names(vars) && nzchar(vars[[field]])) { 569 | version <- vars[[field]] 570 | break 571 | } 572 | } 573 | 574 | # join together 575 | paste(c(os, id, version), collapse = "-") 576 | 577 | } 578 | 579 | renv_bootstrap_platform_os_via_redhat_release <- function() { 580 | 581 | # read /etc/redhat-release 582 | contents <- readLines("/etc/redhat-release", warn = FALSE) 583 | 584 | # infer id 585 | id <- if (grepl("centos", contents, ignore.case = TRUE)) 586 | "centos" 587 | else if (grepl("redhat", contents, ignore.case = TRUE)) 588 | "redhat" 589 | else 590 | "unknown" 591 | 592 | # try to find a version component (very hacky) 593 | version <- "unknown" 594 | 595 | parts <- strsplit(contents, "[[:space:]]")[[1L]] 596 | for (part in parts) { 597 | 598 | nv <- tryCatch(numeric_version(part), error = identity) 599 | if (inherits(nv, "error")) 600 | next 601 | 602 | version <- nv[1, 1] 603 | break 604 | 605 | } 606 | 607 | paste(c("linux", id, version), collapse = "-") 608 | 609 | } 610 | 611 | renv_bootstrap_library_root_name <- function(project) { 612 | 613 | # use project name as-is if requested 614 | asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") 615 | if (asis) 616 | return(basename(project)) 617 | 618 | # otherwise, disambiguate based on project's path 619 | id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) 620 | paste(basename(project), id, sep = "-") 621 | 622 | } 623 | 624 | renv_bootstrap_library_root <- function(project) { 625 | 626 | prefix <- renv_bootstrap_profile_prefix() 627 | 628 | path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) 629 | if (!is.na(path)) 630 | return(paste(c(path, prefix), collapse = "/")) 631 | 632 | path <- renv_bootstrap_library_root_impl(project) 633 | if (!is.null(path)) { 634 | name <- renv_bootstrap_library_root_name(project) 635 | return(paste(c(path, prefix, name), collapse = "/")) 636 | } 637 | 638 | renv_bootstrap_paths_renv("library", project = project) 639 | 640 | } 641 | 642 | renv_bootstrap_library_root_impl <- function(project) { 643 | 644 | root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) 645 | if (!is.na(root)) 646 | return(root) 647 | 648 | type <- renv_bootstrap_project_type(project) 649 | if (identical(type, "package")) { 650 | userdir <- renv_bootstrap_user_dir() 651 | return(file.path(userdir, "library")) 652 | } 653 | 654 | } 655 | 656 | renv_bootstrap_validate_version <- function(version) { 657 | 658 | loadedversion <- utils::packageDescription("renv", fields = "Version") 659 | if (version == loadedversion) 660 | return(TRUE) 661 | 662 | # assume four-component versions are from GitHub; three-component 663 | # versions are from CRAN 664 | components <- strsplit(loadedversion, "[.-]")[[1]] 665 | remote <- if (length(components) == 4L) 666 | paste("rstudio/renv", loadedversion, sep = "@") 667 | else 668 | paste("renv", loadedversion, sep = "@") 669 | 670 | fmt <- paste( 671 | "renv %1$s was loaded from project library, but this project is configured to use renv %2$s.", 672 | "Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.", 673 | "Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.", 674 | sep = "\n" 675 | ) 676 | 677 | msg <- sprintf(fmt, loadedversion, version, remote) 678 | warning(msg, call. = FALSE) 679 | 680 | FALSE 681 | 682 | } 683 | 684 | renv_bootstrap_hash_text <- function(text) { 685 | 686 | hashfile <- tempfile("renv-hash-") 687 | on.exit(unlink(hashfile), add = TRUE) 688 | 689 | writeLines(text, con = hashfile) 690 | tools::md5sum(hashfile) 691 | 692 | } 693 | 694 | renv_bootstrap_load <- function(project, libpath, version) { 695 | 696 | # try to load renv from the project library 697 | if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) 698 | return(FALSE) 699 | 700 | # warn if the version of renv loaded does not match 701 | renv_bootstrap_validate_version(version) 702 | 703 | # load the project 704 | renv::load(project) 705 | 706 | TRUE 707 | 708 | } 709 | 710 | renv_bootstrap_profile_load <- function(project) { 711 | 712 | # if RENV_PROFILE is already set, just use that 713 | profile <- Sys.getenv("RENV_PROFILE", unset = NA) 714 | if (!is.na(profile) && nzchar(profile)) 715 | return(profile) 716 | 717 | # check for a profile file (nothing to do if it doesn't exist) 718 | path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) 719 | if (!file.exists(path)) 720 | return(NULL) 721 | 722 | # read the profile, and set it if it exists 723 | contents <- readLines(path, warn = FALSE) 724 | if (length(contents) == 0L) 725 | return(NULL) 726 | 727 | # set RENV_PROFILE 728 | profile <- contents[[1L]] 729 | if (!profile %in% c("", "default")) 730 | Sys.setenv(RENV_PROFILE = profile) 731 | 732 | profile 733 | 734 | } 735 | 736 | renv_bootstrap_profile_prefix <- function() { 737 | profile <- renv_bootstrap_profile_get() 738 | if (!is.null(profile)) 739 | return(file.path("profiles", profile, "renv")) 740 | } 741 | 742 | renv_bootstrap_profile_get <- function() { 743 | profile <- Sys.getenv("RENV_PROFILE", unset = "") 744 | renv_bootstrap_profile_normalize(profile) 745 | } 746 | 747 | renv_bootstrap_profile_set <- function(profile) { 748 | profile <- renv_bootstrap_profile_normalize(profile) 749 | if (is.null(profile)) 750 | Sys.unsetenv("RENV_PROFILE") 751 | else 752 | Sys.setenv(RENV_PROFILE = profile) 753 | } 754 | 755 | renv_bootstrap_profile_normalize <- function(profile) { 756 | 757 | if (is.null(profile) || profile %in% c("", "default")) 758 | return(NULL) 759 | 760 | profile 761 | 762 | } 763 | 764 | renv_bootstrap_path_absolute <- function(path) { 765 | 766 | substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( 767 | substr(path, 1L, 1L) %in% c(letters, LETTERS) && 768 | substr(path, 2L, 3L) %in% c(":/", ":\\") 769 | ) 770 | 771 | } 772 | 773 | renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { 774 | renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") 775 | root <- if (renv_bootstrap_path_absolute(renv)) NULL else project 776 | prefix <- if (profile) renv_bootstrap_profile_prefix() 777 | components <- c(root, renv, prefix, ...) 778 | paste(components, collapse = "/") 779 | } 780 | 781 | renv_bootstrap_project_type <- function(path) { 782 | 783 | descpath <- file.path(path, "DESCRIPTION") 784 | if (!file.exists(descpath)) 785 | return("unknown") 786 | 787 | desc <- tryCatch( 788 | read.dcf(descpath, all = TRUE), 789 | error = identity 790 | ) 791 | 792 | if (inherits(desc, "error")) 793 | return("unknown") 794 | 795 | type <- desc$Type 796 | if (!is.null(type)) 797 | return(tolower(type)) 798 | 799 | package <- desc$Package 800 | if (!is.null(package)) 801 | return("package") 802 | 803 | "unknown" 804 | 805 | } 806 | 807 | renv_bootstrap_user_dir <- function() { 808 | dir <- renv_bootstrap_user_dir_impl() 809 | path.expand(chartr("\\", "/", dir)) 810 | } 811 | 812 | renv_bootstrap_user_dir_impl <- function() { 813 | 814 | # use local override if set 815 | override <- getOption("renv.userdir.override") 816 | if (!is.null(override)) 817 | return(override) 818 | 819 | # use R_user_dir if available 820 | tools <- asNamespace("tools") 821 | if (is.function(tools$R_user_dir)) 822 | return(tools$R_user_dir("renv", "cache")) 823 | 824 | # try using our own backfill for older versions of R 825 | envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") 826 | for (envvar in envvars) { 827 | root <- Sys.getenv(envvar, unset = NA) 828 | if (!is.na(root)) 829 | return(file.path(root, "R/renv")) 830 | } 831 | 832 | # use platform-specific default fallbacks 833 | if (Sys.info()[["sysname"]] == "Windows") 834 | file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") 835 | else if (Sys.info()[["sysname"]] == "Darwin") 836 | "~/Library/Caches/org.R-project.R/R/renv" 837 | else 838 | "~/.cache/R/renv" 839 | 840 | } 841 | 842 | 843 | renv_json_read <- function(file = NULL, text = NULL) { 844 | 845 | # if jsonlite is loaded, use that instead 846 | if ("jsonlite" %in% loadedNamespaces()) 847 | renv_json_read_jsonlite(file, text) 848 | else 849 | renv_json_read_default(file, text) 850 | 851 | } 852 | 853 | renv_json_read_jsonlite <- function(file = NULL, text = NULL) { 854 | text <- paste(text %||% read(file), collapse = "\n") 855 | jsonlite::fromJSON(txt = text, simplifyVector = FALSE) 856 | } 857 | 858 | renv_json_read_default <- function(file = NULL, text = NULL) { 859 | 860 | # find strings in the JSON 861 | text <- paste(text %||% read(file), collapse = "\n") 862 | pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' 863 | locs <- gregexpr(pattern, text, perl = TRUE)[[1]] 864 | 865 | # if any are found, replace them with placeholders 866 | replaced <- text 867 | strings <- character() 868 | replacements <- character() 869 | 870 | if (!identical(c(locs), -1L)) { 871 | 872 | # get the string values 873 | starts <- locs 874 | ends <- locs + attr(locs, "match.length") - 1L 875 | strings <- substring(text, starts, ends) 876 | 877 | # only keep those requiring escaping 878 | strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) 879 | 880 | # compute replacements 881 | replacements <- sprintf('"\032%i\032"', seq_along(strings)) 882 | 883 | # replace the strings 884 | mapply(function(string, replacement) { 885 | replaced <<- sub(string, replacement, replaced, fixed = TRUE) 886 | }, strings, replacements) 887 | 888 | } 889 | 890 | # transform the JSON into something the R parser understands 891 | transformed <- replaced 892 | transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) 893 | transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) 894 | transformed <- gsub("[]}]", ")", transformed, perl = TRUE) 895 | transformed <- gsub(":", "=", transformed, fixed = TRUE) 896 | text <- paste(transformed, collapse = "\n") 897 | 898 | # parse it 899 | json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] 900 | 901 | # construct map between source strings, replaced strings 902 | map <- as.character(parse(text = strings)) 903 | names(map) <- as.character(parse(text = replacements)) 904 | 905 | # convert to list 906 | map <- as.list(map) 907 | 908 | # remap strings in object 909 | remapped <- renv_json_remap(json, map) 910 | 911 | # evaluate 912 | eval(remapped, envir = baseenv()) 913 | 914 | } 915 | 916 | renv_json_remap <- function(json, map) { 917 | 918 | # fix names 919 | if (!is.null(names(json))) { 920 | lhs <- match(names(json), names(map), nomatch = 0L) 921 | rhs <- match(names(map), names(json), nomatch = 0L) 922 | names(json)[rhs] <- map[lhs] 923 | } 924 | 925 | # fix values 926 | if (is.character(json)) 927 | return(map[[json]] %||% json) 928 | 929 | # handle true, false, null 930 | if (is.name(json)) { 931 | text <- as.character(json) 932 | if (text == "true") 933 | return(TRUE) 934 | else if (text == "false") 935 | return(FALSE) 936 | else if (text == "null") 937 | return(NULL) 938 | } 939 | 940 | # recurse 941 | if (is.recursive(json)) { 942 | for (i in seq_along(json)) { 943 | json[i] <- list(renv_json_remap(json[[i]], map)) 944 | } 945 | } 946 | 947 | json 948 | 949 | } 950 | 951 | # load the renv profile, if any 952 | renv_bootstrap_profile_load(project) 953 | 954 | # construct path to library root 955 | root <- renv_bootstrap_library_root(project) 956 | 957 | # construct library prefix for platform 958 | prefix <- renv_bootstrap_platform_prefix() 959 | 960 | # construct full libpath 961 | libpath <- file.path(root, prefix) 962 | 963 | # attempt to load 964 | if (renv_bootstrap_load(project, libpath, version)) 965 | return(TRUE) 966 | 967 | # load failed; inform user we're about to bootstrap 968 | prefix <- paste("# Bootstrapping renv", version) 969 | postfix <- paste(rep.int("-", 77L - nchar(prefix)), collapse = "") 970 | header <- paste(prefix, postfix) 971 | message(header) 972 | 973 | # perform bootstrap 974 | bootstrap(version, libpath) 975 | 976 | # exit early if we're just testing bootstrap 977 | if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) 978 | return(TRUE) 979 | 980 | # try again to load 981 | if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { 982 | message("* Successfully installed and loaded renv ", version, ".") 983 | return(renv::load()) 984 | } 985 | 986 | # failed to download or load renv; warn the user 987 | msg <- c( 988 | "Failed to find an renv installation: the project will not be loaded.", 989 | "Use `renv::activate()` to re-initialize the project." 990 | ) 991 | 992 | warning(paste(msg, collapse = "\n"), call. = FALSE) 993 | 994 | }) 995 | --------------------------------------------------------------------------------